From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 22 Apr 2018 05:08:44 +0000 (-0700)
Subject: Eliminate remaining uses of find-matching-item.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~119
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=912326735140d7562cc22f47dc64be957289f060;p=mit-scheme.git

Eliminate remaining uses of find-matching-item.
---

diff --git a/src/compiler/machines/svm/assembler-compiler.scm b/src/compiler/machines/svm/assembler-compiler.scm
index 1e9690e44..44385fb33 100644
--- a/src/compiler/machines/svm/assembler-compiler.scm
+++ b/src/compiler/machines/svm/assembler-compiler.scm
@@ -72,9 +72,9 @@ USA.
 	    (queue->list defns))))
 
 (define (find-coding-type name coding-types #!optional error?)
-  (or (find-matching-item coding-types
-	(lambda (type)
-	  (eq? (coding-type-name type) name)))
+  (or (find (lambda (type)
+	      (eq? (coding-type-name type) name))
+	    coding-types)
       (and (if (default-object? error?) #t error?)
 	   (error "Unknown coding-type name:" name))))
 
@@ -164,9 +164,9 @@ USA.
     ;; Compute initial references.
     (let ((find-node
 	   (lambda (coding-type)
-	     (find-matching-item nodes
-	       (lambda (node)
-		 (eq? (vector-ref node 0) coding-type))))))
+	     (find (lambda (node)
+		     (eq? (vector-ref node 0) coding-type))
+		   nodes))))
       (for-each (lambda (coding-type from)
 		  (for-each (lambda (to)
 			      (enqueue! queue (cons from (find-node to))))
@@ -259,9 +259,9 @@ USA.
       (let ((outputs
 	     (append-map (lambda (input)
 			   (let ((abbrev
-				  (find-matching-item abbrevs
-				    (lambda (abbrev)
-				      (syntax-match? (car abbrev) input)))))
+				  (find (lambda (abbrev)
+					  (syntax-match? (car abbrev) input))
+					abbrevs)))
 			     (if abbrev
 				 (begin
 				   (set! any-expansions? #t)
@@ -366,9 +366,9 @@ USA.
 		  has-code?
 		  (map (lambda (item)
 			 (guarantee symbol? item #f)
-			 (or (find-matching-item pvars
-			       (lambda (pv)
-				 (eq? (pvar-name pv) item)))
+			 (or (find (lambda (pv)
+				     (eq? (pvar-name pv) item))
+				   pvars)
 			     (error "Missing name reference:" item)))
 		       coding)))))
 
@@ -415,9 +415,9 @@ USA.
 	 to-expand
 	 (append-map! (lambda (defn)
 			(let ((pv
-			       (find-matching-item (defn-pvars defn)
-				 (lambda (pv)
-				   (eq? (pvar-type pv) type-name)))))
+			       (find (lambda (pv)
+				       (eq? (pvar-type pv) type-name))
+				     (defn-pvars defn))))
 			  (if pv
 			      (begin
 				(set! any-changes? #t)
@@ -562,9 +562,9 @@ USA.
 
 (define (map-key-abbrevs keyword key-abbrevs)
   (let ((key-abbrev
-	 (find-matching-item key-abbrevs
-	   (lambda (key-abbrev)
-	     (eq? (key-abbrev-keyword key-abbrev) keyword)))))
+	 (find (lambda (key-abbrev)
+		 (eq? (key-abbrev-keyword key-abbrev) keyword))
+	       key-abbrevs)))
     (if key-abbrev
 	(key-abbrev-abbreviation key-abbrev)
 	keyword)))
diff --git a/src/compiler/machines/svm/assembler-runtime.scm b/src/compiler/machines/svm/assembler-runtime.scm
index 62d31d9ca..43703e262 100644
--- a/src/compiler/machines/svm/assembler-runtime.scm
+++ b/src/compiler/machines/svm/assembler-runtime.scm
@@ -45,9 +45,9 @@ USA.
 (define rt-coding-types '())
 
 (define (make-rt-coding-type name defns)
-  (if (find-matching-item rt-coding-types
-	(lambda (rt-coding-type)
-	  (eq? (rt-coding-type-name rt-coding-type) name)))
+  (if (find (lambda (rt-coding-type)
+	      (eq? (rt-coding-type-name rt-coding-type) name))
+	    rt-coding-types)
       (error "Coding type already exists" name)
       (set! rt-coding-types
 	    (cons (%make-rt-coding-type name defns) rt-coding-types))))
@@ -387,18 +387,18 @@ USA.
   (let ((type (rt-coding-type name))
 	(code (read-byte)))
     (let ((defn
-	    (find-matching-item (rt-coding-type-defns type)
-	     (lambda (defn)
-	       (eqv? (rt-defn-code defn) code)))))
+	    (find (lambda (defn)
+		    (eqv? (rt-defn-code defn) code))
+		  (rt-coding-type-defns type))))
       (if defn
 	  (cons (rt-defn-name defn)
 		((rt-defn-decoder defn) read-byte))
 	  (coding-error code type)))))
 
 (define (rt-coding-type name)
-  (or (find-matching-item rt-coding-types
-	(lambda (rt-coding-type)
-	  (eq? (rt-coding-type-name rt-coding-type) name)))
+  (or (find (lambda (rt-coding-type)
+	      (eq? (rt-coding-type-name rt-coding-type) name))
+	    rt-coding-types)
       (error:bad-range-argument name 'RT-CODING-TYPE)))
 
 (define condition-type:coding-error
diff --git a/src/compiler/machines/svm/disassembler.scm b/src/compiler/machines/svm/disassembler.scm
index 072314581..71311302f 100644
--- a/src/compiler/machines/svm/disassembler.scm
+++ b/src/compiler/machines/svm/disassembler.scm
@@ -313,13 +313,12 @@ USA.
 		 (system-vector-ref block index)))
 	 (refs (system-hunk3-cxr2 cache))
 	 (entry
-	  (find-matching-item
-	   (case kind
-	     ((1) (system-hunk3-cxr0 refs))
-	     ((2) (system-hunk3-cxr1 refs))
-	     (else (error "Not a kind of variable cache:" kind)))
-	   (lambda (e)
-	     (weak-assq block (cdr e))))))
+	  (find (lambda (e)
+		  (weak-assq block (cdr e)))
+		(case kind
+		  ((1) (system-hunk3-cxr0 refs))
+		  ((2) (system-hunk3-cxr1 refs))
+		  (else (error "Not a kind of variable cache:" kind))))))
     (write-string "variable cache for ")
     (if (pair? entry)
 	(write (car entry))
diff --git a/src/cref/forpkg.scm b/src/cref/forpkg.scm
index fda8a028f..f0d5809b4 100644
--- a/src/cref/forpkg.scm
+++ b/src/cref/forpkg.scm
@@ -300,9 +300,9 @@ USA.
 	(value-cell (expression/value-cell expression)))
     (let ((binding
 	   (and value-cell
-		(find-matching-item (value-cell/bindings value-cell)
-		  (lambda (binding)
-		    (eq? package* (binding/package binding)))))))
+		(find (lambda (binding)
+			(eq? package* (binding/package binding)))
+		      (value-cell/bindings value-cell)))))
       (if binding
 	  (let ((name (binding/name binding)))
 	    (if (and package
diff --git a/src/cref/object.scm b/src/cref/object.scm
index d4f1d7c81..f6956190c 100644
--- a/src/cref/object.scm
+++ b/src/cref/object.scm
@@ -69,16 +69,16 @@ USA.
   (null? (package/name package)))
 
 (define-integrable (package/find-reference package name)
-  (find-matching-item (package/references package)
-		      (lambda (ref) (eq? (reference/name ref) name))))
+  (find (lambda (ref) (eq? (reference/name ref) name))
+	(package/references package)))
 
 (define-integrable (package/put-reference! package reference)
   (set-package/references! package
 			   (cons reference (package/references package))))
 
 (define-integrable (package/find-binding package name)
-  (find-matching-item (package/bindings package)
-		      (lambda (ref) (eq? (binding/name ref) name))))
+  (find (lambda (ref) (eq? (binding/name ref) name))
+	(package/bindings package)))
 
 (define-integrable (package/put-binding! package binding)
   (set-package/bindings! package
diff --git a/src/edwin/sendmail.scm b/src/edwin/sendmail.scm
index c73536b23..170401af9 100644
--- a/src/edwin/sendmail.scm
+++ b/src/edwin/sendmail.scm
@@ -363,9 +363,9 @@ is inserted."
     (let ((given-header?
 	   (lambda (name null-true?)
 	     (let ((header
-		    (find-matching-item headers
-		      (lambda (header)
-			(string-ci=? (car header) name)))))
+		    (find (lambda (header)
+			    (string-ci=? (car header) name))
+			  headers)))
 	       (and header
 		    (cadr header)
 		    (if null-true?
@@ -1786,15 +1786,14 @@ Otherwise, the MIME type is determined from the file's suffix;
 	     (if prompt?
 		 (do-mime)
 		 (let ((entry
-			(find-matching-item
-			    (ref-variable file-type-to-mime-type buffer)
-			  (lambda (entry)
-			    (cond ((string? type)
-				   (string-ci=? (car entry) type))
-				  ((not type)
-				   (not (car entry)))
-				  (else
-				   (eq? type 'WILD)))))))
+			(find (lambda (entry)
+				(cond ((string? type)
+				       (string-ci=? (car entry) type))
+				      ((not type)
+				       (not (car entry)))
+				      (else
+				       (eq? type 'WILD))))
+			      (ref-variable file-type-to-mime-type buffer))))
 		   (cond (entry (make-mime-type (cadr entry) (caddr entry)))
 			 ((pathname-mime-type pathname))
 			 (else
diff --git a/src/edwin/unix.scm b/src/edwin/unix.scm
index 93521f946..ca3b700b4 100644
--- a/src/edwin/unix.scm
+++ b/src/edwin/unix.scm
@@ -192,11 +192,11 @@ Includes the new backup.  Must be > 0."
 
 (define (os/newest-backup pathname)
   (or (os/newest-numeric-backup pathname)
-      (find-matching-item
-          (os/directory-list-completions
-           (directory-namestring pathname)
-           (string-append (file-namestring pathname) "~"))
-        os/backup-filename?)))
+      (find
+       os/backup-filename?
+       (os/directory-list-completions
+	(directory-namestring pathname)
+	(string-append (file-namestring pathname) "~")))))
 
 (define (os/buffer-backup-pathname truename buffer)
   (call-with-values
@@ -666,9 +666,8 @@ option, instead taking -P <filename>."
 
 (define (os/sendmail-program)
   (or (os/find-program "sendmail" #f (ref-variable exec-path) #f)
-      (find-matching-item
-	  '("/usr/sbin/sendmail" "/usr/lib/sendmail" "/usr/ucblib/sendmail")
-	file-executable?)
+      (find file-executable?
+	    '("/usr/sbin/sendmail" "/usr/lib/sendmail" "/usr/ucblib/sendmail"))
       "fakemail"))
 
 (define (os/newsrc-file-name server)
diff --git a/src/ffi/generator.scm b/src/ffi/generator.scm
index 6f63df43b..6ec510a60 100644
--- a/src/ffi/generator.scm
+++ b/src/ffi/generator.scm
@@ -147,8 +147,8 @@ Scm_"name" (void)
 "))))))
 
 (define (matching-param? string params)
-  (find-matching-item params
-    (lambda (param) (string=? string (symbol->string (car param))))))
+  (find (lambda (param) (string=? string (symbol->string (car param))))
+	params))
 
 (define (new-variable root-name params)
   ;; Returns a name (string) for a variable that must be distinct from
diff --git a/src/sf/emodel.scm b/src/sf/emodel.scm
index dd83438bd..8292d0bff 100644
--- a/src/sf/emodel.scm
+++ b/src/sf/emodel.scm
@@ -50,9 +50,9 @@ USA.
 	    (and intern? (%variable/make&bind! block name))))))
 
 (define (%block/lookup-name block name)
-  (find-matching-item (block/bound-variables block)
-		      (lambda (variable)
-			(eq? (variable/name variable) name))))
+  (find (lambda (variable)
+	  (eq? (variable/name variable) name))
+	(block/bound-variables block)))
 
 (define (block/limited-lookup block name limit)
   (guarantee symbol? name 'block/limited-lookup)
diff --git a/src/ssp/mod-lisp.scm b/src/ssp/mod-lisp.scm
index a7db288cc..ccce2e8a9 100644
--- a/src/ssp/mod-lisp.scm
+++ b/src/ssp/mod-lisp.scm
@@ -770,9 +770,9 @@ USA.
 (define (define-url-bindings url . klist)
   (guarantee keyword-list? klist 'define-url-bindings)
   (let* ((binding
-	  (find-matching-item url-bindings
-	    (lambda (binding)
-	      (string=? (car binding) url)))))
+	  (find (lambda (binding)
+		  (string=? (car binding) url))
+		url-bindings)))
     (if binding
 	(do ((klist klist (cddr klist)))
 	    ((not (pair? klist)))
diff --git a/src/star-parser/shared.scm b/src/star-parser/shared.scm
index dc3f384ea..719e5dd22 100644
--- a/src/star-parser/shared.scm
+++ b/src/star-parser/shared.scm
@@ -675,12 +675,12 @@ USA.
   (pp pointers)
   (newline)
   |#
-  (cond ((or (find-matching-item pointer-optimizations
-	       (lambda (p)
-		 (syntax-match? (car p) expression)))
-	     (find-matching-item default-pointer-optimizations
-	       (lambda (p)
-		 (syntax-match? (car p) expression))))
+  (cond ((or (find (lambda (p)
+		     (syntax-match? (car p) expression))
+		   pointer-optimizations)
+	     (find (lambda (p)
+		     (syntax-match? (car p) expression))
+		   default-pointer-optimizations))
 	 => (lambda (p)
 	      (let ((expression* ((cdr p) expression pointers)))
 		(if (equal? expression* expression)
@@ -779,15 +779,15 @@ USA.
 
 (define (%current-pointers pointers)
   (if (car pointers)
-      (find-matching-item (cdr pointers)
-	(lambda (identifiers)
-	  (memq (car pointers) identifiers)))
+      (find (lambda (identifiers)
+	      (memq (car pointers) identifiers))
+	    (cdr pointers))
       '()))
 
 (define (%id-pointers identifier pointers)
-  (or (find-matching-item (cdr pointers)
-	(lambda (ids)
-	  (memq identifier ids)))
+  (or (find (lambda (ids)
+	      (memq identifier ids))
+	    (cdr pointers))
       '()))
 
 (define-pointer-optimization
diff --git a/src/xdoc/xdoc.scm b/src/xdoc/xdoc.scm
index 58be6d823..067ade24a 100644
--- a/src/xdoc/xdoc.scm
+++ b/src/xdoc/xdoc.scm
@@ -723,9 +723,9 @@ USA.
     (let per-elt ((elt elt) (containers (xdoc-element-containers elt)))
       (let* ((id (xdoc-db-id elt))
 	     (suffix (string-append "-" (symbol->string id))))
-	(cond ((find-matching-item bindings
-		 (lambda (binding)
-		   (string-suffix? suffix (symbol->string (car binding)))))
+	(cond ((find (lambda (binding)
+		       (string-suffix? suffix (symbol->string (car binding))))
+		     bindings)
 	       => (lambda (binding)
 		    (values (let ((name (symbol->string (car binding))))
 			      (substring->symbol
@@ -1178,9 +1178,9 @@ USA.
 	  #f))))
 
 (define (%find-attribute name attrs)
-  (find-matching-item attrs
-    (lambda (attr)
-      (xml-name=? (xml-attribute-name attr) name))))
+  (find (lambda (attr)
+	  (xml-name=? (xml-attribute-name attr) name))
+	attrs))
 
 (define (symbol-attribute name elt error?)
   (let ((string (find-attribute name elt error?)))
@@ -1336,10 +1336,10 @@ USA.
   (%find-result (%find-child elt predicate) error?))
 
 (define (%find-child elt predicate)
-  (find-matching-item (xml-element-contents elt)
-    (lambda (item)
-      (and (xml-element? item)
-	   (predicate item)))))
+  (find (lambda (item)
+	  (and (xml-element? item)
+	       (predicate item)))
+	(xml-element-contents elt)))
 
 (define (%find-result elt error?)
   (if (and (not elt) error?)
diff --git a/src/xml/rdf-struct.scm b/src/xml/rdf-struct.scm
index e691d367c..70a656714 100644
--- a/src/xml/rdf-struct.scm
+++ b/src/xml/rdf-struct.scm
@@ -292,11 +292,11 @@ USA.
 		  (registry-bindings
 		   (check-registry registry 'URI->RDF-PREFIX)))
 		 (filter (lambda (p) (string-prefix? (cdr p) s))))
-	     (or (find-matching-item alist
-		   (lambda (p)
-		     (and (not (eq? (car p) ':))
-			  (filter p))))
-		 (find-matching-item alist filter)))))
+	     (or (find (lambda (p)
+			 (and (not (eq? (car p) ':))
+			      (filter p)))
+		       alist)
+		 (find filter alist)))))
       (if p
 	  (values (car p) (cdr p))
 	  (begin
diff --git a/src/xml/xml-parser.scm b/src/xml/xml-parser.scm
index e6d90c06b..a8ebcaaaa 100644
--- a/src/xml/xml-parser.scm
+++ b/src/xml/xml-parser.scm
@@ -430,9 +430,9 @@ USA.
 (define (process-attr-decls name attrs p)
   (let ((decl
 	 (and (or *standalone?* *internal-dtd?*)
-	      (find-matching-item *att-decls*
-		(lambda (decl)
-		  (xml-name=? (xml-!attlist-name decl) name))))))
+	      (find (lambda (decl)
+		      (xml-name=? (xml-!attlist-name decl) name))
+		    *att-decls*))))
     (if decl
 	(do ((defns (xml-!attlist-definitions decl) (cdr defns))
 	     (attrs attrs (process-attr-defn (car defns) attrs p)))
@@ -444,9 +444,9 @@ USA.
 	(type (cadr defn))
 	(default (caddr defn)))
     (let ((attr
-	   (find-matching-item attrs
-	     (lambda (attr)
-	       (xml-name=? (car (xml-attribute-name attr)) name)))))
+	   (find (lambda (attr)
+		   (xml-name=? (car (xml-attribute-name attr)) name))
+		 attrs)))
       (if attr
 	  (let ((av (xml-attribute-value attr)))
 	    (if (and (pair? default)
@@ -946,9 +946,9 @@ USA.
 	  (make-xml-parameter-entity-ref name)))))
 
 (define (find-parameter-entity name)
-  (find-matching-item *parameter-entities*
-    (lambda (entity)
-      (eq? name (xml-parameter-!entity-name entity)))))
+  (find (lambda (entity)
+	  (eq? name (xml-parameter-!entity-name entity)))
+	*parameter-entities*))
 
 (define *parameter-entities*)
 
diff --git a/src/xml/xml-rpc.scm b/src/xml/xml-rpc.scm
index 82b17c0ad..a0453b67c 100644
--- a/src/xml/xml-rpc.scm
+++ b/src/xml/xml-rpc.scm
@@ -199,10 +199,10 @@ USA.
     child))
 
 (define (%named-child name elt)
-  (find-matching-item (xml-element-contents elt)
-    (lambda (item)
-      (and (xml-element? item)
-	   (xml-name=? (xml-element-name item) name)))))
+  (find (lambda (item)
+	  (and (xml-element? item)
+	       (xml-name=? (xml-element-name item) name)))
+	(xml-element-contents elt)))
 
 (define (single-child elt)
   (let ((children (all-children elt)))