From: Chris Hanson Date: Sun, 22 Apr 2018 05:05:07 +0000 (-0700) Subject: Eliminate remaining uses of list-search-positive. X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~120 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f02e4750ba53ca5e0c0932d53e0ff646bf3a6bd9;p=mit-scheme.git Eliminate remaining uses of list-search-positive. --- diff --git a/src/compiler/back/mermap.scm b/src/compiler/back/mermap.scm index 289b7bc6f..73c6ff371 100644 --- a/src/compiler/back/mermap.scm +++ b/src/compiler/back/mermap.scm @@ -66,9 +66,9 @@ USA. (let ((homes (cdr conflicting-alias))) (let ((maximum (apply max (map cdr homes)))) (let ((winner - (list-search-positive homes - (lambda (home) - (= (cdr home) maximum))))) + (find (lambda (home) + (= (cdr home) maximum)) + homes))) (for-each (lambda (home) (if (not (eq? home winner)) @@ -111,10 +111,10 @@ USA. (define (add-weighted-entries x-entries y-entries) (merge-entries x-entries y-entries (lambda (entry entries) - (list-search-positive entries - (let ((home (vector-ref entry 0))) - (lambda (entry) - (eqv? home (vector-ref entry 0)))))) + (find (let ((home (vector-ref entry 0))) + (lambda (entry) + (eqv? home (vector-ref entry 0)))) + entries)) (lambda (x-entry y-entry) (vector (vector-ref x-entry 0) (min (vector-ref x-entry 1) (vector-ref y-entry 1)) diff --git a/src/compiler/back/regmap.scm b/src/compiler/back/regmap.scm index c4e8693f7..479f7a704 100644 --- a/src/compiler/back/regmap.scm +++ b/src/compiler/back/regmap.scm @@ -188,10 +188,10 @@ registers into some interesting sorting order. (car (map-entry-aliases entry))) (define (map-entry:find-alias entry type needed-registers) - (list-search-positive (map-entry-aliases entry) - (lambda (alias) - (and (register-type? alias type) - (not (memv alias needed-registers)))))) + (find (lambda (alias) + (and (register-type? alias type) + (not (memv alias needed-registers)))) + (map-entry-aliases entry))) (define (map-entry:aliases entry type needed-registers) (filter (lambda (alias) @@ -346,10 +346,10 @@ registers into some interesting sorting order. (else (and (not (null? y-entries)) (let ((y-entry - (list-search-positive y-entries - (let ((home (map-entry-home (car x-entries)))) - (lambda (entry) - (eqv? (map-entry-home entry) home)))))) + (find (let ((home (map-entry-home (car x-entries)))) + (lambda (entry) + (eqv? (map-entry-home entry) home))) + y-entries))) (and y-entry (boolean=? (map-entry-saved-into-home? (car x-entries)) (map-entry-saved-into-home? y-entry)) @@ -428,10 +428,10 @@ registers into some interesting sorting order. (LAP))))) ;; First see if there is an unused register of the given type. (or (let ((register - (list-search-positive (map-registers map) - (lambda (alias) - (and (register-type? alias type) - (not (memv alias needed-registers))))))) + (find (lambda (alias) + (and (register-type? alias type) + (not (memv alias needed-registers)))) + (map-registers map)))) (and register (allocator-values register map (LAP)))) ;; There are no free registers available, so must reallocate ;; one. First look for a temporary register that is no longer @@ -480,10 +480,10 @@ registers into some interesting sorting order. (define (allocate-register-without-unload? map type needed-registers) ;; True iff a register of `type' can be allocated without displacing ;; any pseudo-registers from the register map. - (or (list-search-positive (map-registers map) - (lambda (alias) - (and (register-type? alias type) - (not (memv alias needed-registers))))) + (or (find (lambda (alias) + (and (register-type? alias type) + (not (memv alias needed-registers)))) + (map-registers map)) (map-entries:search map (lambda (entry) (and (map-entry:find-alias entry type needed-registers) @@ -497,8 +497,8 @@ registers into some interesting sorting order. ;; contents into that register. (or (let ((entry (map-entries:find-home map home))) (and entry - (let ((alias (list-search-positive (map-entry-aliases entry) - (register-type-predicate type)))) + (let ((alias (find (register-type-predicate type) + (map-entry-aliases entry)))) (and alias (allocator-values alias map (LAP)))))) (bind-allocator-values (make-free-register map type needed-registers) @@ -556,18 +556,18 @@ registers into some interesting sorting order. the same value as REGISTER. If no such register exists, returns #F." (let ((entry (map-entries:find-alias map register))) (and entry - (list-search-positive (map-entry-aliases entry) - (lambda (register*) - (and (not (eq? register register*)) - (register-type? type register*))))))) + (find (lambda (register*) + (and (not (eq? register register*)) + (register-type? type register*))) + (map-entry-aliases entry))))) (define (pseudo-register-alias map type register) "Returns a machine register, of the given TYPE, which is an alias for REGISTER. If no such register exists, returns #F." (let ((entry (map-entries:find-home map register))) (and entry - (list-search-positive (map-entry-aliases entry) - (register-type-predicate type))))) + (find (register-type-predicate type) + (map-entry-aliases entry))))) (define (machine-register-is-unique? map register) "True if REGISTER has no other aliases." @@ -585,9 +585,9 @@ for REGISTER. If no such register exists, returns #F." (define (is-pseudo-register-alias? map maybe-alias register) (let ((entry (map-entries:find-home map register))) (and entry - (list-search-positive (map-entry-aliases entry) - (lambda (alias) - (eqv? maybe-alias alias)))))) + (find (lambda (alias) + (eqv? maybe-alias alias)) + (map-entry-aliases entry))))) (define (save-machine-register map register receiver) (let ((entry (map-entries:find-alias map register))) diff --git a/src/compiler/base/constr.scm b/src/compiler/base/constr.scm index 3f3aeca72..d1ace0750 100644 --- a/src/compiler/base/constr.scm +++ b/src/compiler/base/constr.scm @@ -71,7 +71,7 @@ USA. (if (eqv? element (constraint/element constraint)) constraint (loop (constraint/afters constraint)))) - + (loop (constraint-graph/entry-nodes graph-head))) (define (find-or-make-constraint element graph-head @@ -80,7 +80,7 @@ USA. (if (default-object? afters) (make-constraint element graph-head) (make-constraint element graph-head afters)))) - + (define (constraint-add! before after) (if (eq? (constraint/element before) (constraint/element after)) @@ -88,7 +88,7 @@ USA. (set-constraint/afters! before (cons after (constraint/afters before))) (let ((c-graph (constraint/graph-head after))) (if c-graph - (set-constraint-graph/entry-nodes! + (set-constraint-graph/entry-nodes! c-graph (delq! after (constraint-graph/entry-nodes c-graph))))) (set-constraint/closed?! before false) @@ -178,13 +178,11 @@ USA. (result '())) (if (and (pair? linearized-constraints) (pair? things)) - (let ((match (list-search-positive - things - (lambda (thing) - (eqv? - (constraint/element - (car linearized-constraints)) - (element-extractor thing)))))) + (let ((match + (find (lambda (thing) + (eqv? (constraint/element (car linearized-constraints)) + (element-extractor thing))) + things))) (loop (cdr linearized-constraints) (delv match things) (if (and match @@ -223,7 +221,7 @@ USA. node-marked?) (define result) - + (define (loop node) (node-mark! node) (for-each next (get-children node)) @@ -233,7 +231,7 @@ USA. (and node (not (node-marked? node)) (loop node))) - + (define (doit node) (set! result '()) (loop node) @@ -261,4 +259,3 @@ USA. (define (constraint-mark! constraint) (set-constraint/generation! constraint *constraint-generation*)) - diff --git a/src/compiler/fgopt/blktyp.scm b/src/compiler/fgopt/blktyp.scm index 3d97213c6..92e6a9cc0 100644 --- a/src/compiler/fgopt/blktyp.scm +++ b/src/compiler/fgopt/blktyp.scm @@ -265,9 +265,9 @@ USA. (define (merge-children! block procedure unconditional conditional update?) (let ((ic-parent (let ((block - (list-search-positive unconditional - (lambda (block*) - (block-parent (block-parent block*)))))) + (find (lambda (block*) + (block-parent (block-parent block*))) + unconditional))) (and block (block-parent (block-parent block))))) (closed-over-variables diff --git a/src/compiler/fgopt/reteqv.scm b/src/compiler/fgopt/reteqv.scm index 0fe8830d2..4559606d7 100644 --- a/src/compiler/fgopt/reteqv.scm +++ b/src/compiler/fgopt/reteqv.scm @@ -74,9 +74,9 @@ USA. (begin (node-mark! node) (let ((class - (list-search-positive classes - (lambda (class) - (node=? node (car class)))))) + (find (lambda (class) + (node=? node (car class))) + classes))) (if class (set-cdr! class (cons node (cdr class))) (begin diff --git a/src/compiler/machines/C/lapgen.scm b/src/compiler/machines/C/lapgen.scm index f9a227180..92548e98f 100644 --- a/src/compiler/machines/C/lapgen.scm +++ b/src/compiler/machines/C/lapgen.scm @@ -396,9 +396,9 @@ USA. (define (object-label-value label) (let ((entry - (list-search-positive (table->list-of-entries objects) - (lambda (entry) - (string=? label (entry-label entry)))))) + (find (lambda (entry) + (string=? label (entry-label entry))) + (table->list-of-entries objects)))) (if (not entry) (error "object-label-value: Unknown" label) (entry-value entry)))) diff --git a/src/compiler/rtlopt/rtlcsm.scm b/src/compiler/rtlopt/rtlcsm.scm index 755d6c8a0..cfbdb7174 100644 --- a/src/compiler/rtlopt/rtlcsm.scm +++ b/src/compiler/rtlopt/rtlcsm.scm @@ -134,22 +134,22 @@ USA. (let ((classes '()) (class-member? (lambda (class suffix) - (list-search-positive class - (lambda (suffix*) - (and (eq? (car suffix) (car suffix*)) - (eq? (cdr suffix) (cdr suffix*)))))))) + (find (lambda (suffix*) + (and (eq? (car suffix) (car suffix*)) + (eq? (cdr suffix) (cdr suffix*)))) + class)))) (for-each (lambda (entry) (let ((class - (list-search-positive classes - (lambda (class) - (class-member? class (car entry)))))) + (find (lambda (class) + (class-member? class (car entry))) + classes))) (if class (if (not (class-member? class (cdr entry))) (set-cdr! class (cons (cdr entry) (cdr class)))) (let ((class - (list-search-positive classes - (lambda (class) - (class-member? class (cdr entry)))))) + (find (lambda (class) + (class-member? class (cdr entry))) + classes))) (if class (set-cdr! class (cons (car entry) (cdr class))) (set! classes diff --git a/src/cref/redpkg.scm b/src/cref/redpkg.scm index 75dd00152..632d9b951 100644 --- a/src/cref/redpkg.scm +++ b/src/cref/redpkg.scm @@ -614,9 +614,9 @@ USA. (package-loop (package/parent package)))))) (define (name->package packages name) - (list-search-positive packages - (lambda (package) - (symbol-list=? name (package/name package))))) + (find (lambda (package) + (symbol-list=? name (package/name package))) + packages)) (define (process-package-description package description get-package) (let ((file-cases (package-description/file-cases description))) diff --git a/src/edwin/artdebug.scm b/src/edwin/artdebug.scm index dfa4e5a37..56d947357 100644 --- a/src/edwin/artdebug.scm +++ b/src/edwin/artdebug.scm @@ -889,9 +889,9 @@ Prefix argument means do not kill the debugger buffer." (define (continuation-browser-abort restarts) (let ((restart - (list-search-positive restarts - (lambda (restart) - (eq? (restart/name restart) 'abort))))) + (find (lambda (restart) + (eq? (restart/name restart) 'abort)) + restarts))) (if (not restart) (editor-error "Can't find an abort restart") (fluid-let ((hook/invoke-restart diff --git a/src/edwin/calias.scm b/src/edwin/calias.scm index a19eac61e..ec0e35701 100644 --- a/src/edwin/calias.scm +++ b/src/edwin/calias.scm @@ -73,9 +73,9 @@ USA. (+ code (if (<= #x01 code #x1A) #x60 #x40))) (fix:or (char-bits key) char-bit:control))) (let ((entry - (list-search-positive alias-keys - (lambda (entry) - (eqv? (cdr entry) key))))) + (find (lambda (entry) + (eqv? (cdr entry) key)) + alias-keys))) (if entry (unmap-alias-key (car entry)) key)))) diff --git a/src/edwin/debug.scm b/src/edwin/debug.scm index 1772b847f..fc8d1e7de 100644 --- a/src/edwin/debug.scm +++ b/src/edwin/debug.scm @@ -512,10 +512,10 @@ USA. (let ((environment (bline/evaluation-environment bline))) (bline/attached-buffer bline 'ENVIRONMENT-BROWSER (lambda () - (or (list-search-positive (buffer-list) - (lambda (buffer) - (let ((browser (buffer-get buffer 'BROWSER))) - (and browser (eq? environment (browser/object browser)))))) + (or (find (lambda (buffer) + (let ((browser (buffer-get buffer 'BROWSER))) + (and browser (eq? environment (browser/object browser))))) + (buffer-list)) (environment-browser-buffer environment)))))) (define (bline/attached-buffer bline type make-buffer) diff --git a/src/edwin/dired.scm b/src/edwin/dired.scm index bb37c5b08..4a1d4877d 100644 --- a/src/edwin/dired.scm +++ b/src/edwin/dired.scm @@ -158,9 +158,9 @@ Type `h' after entering dired for more info." buffer))))) (define (find-dired-buffer directory-spec) - (list-search-positive (buffer-list) - (lambda (buffer) - (equal? directory-spec (buffer-get buffer 'DIRED-DIRECTORY-SPEC))))) + (find (lambda (buffer) + (equal? directory-spec (buffer-get buffer 'DIRED-DIRECTORY-SPEC))) + (buffer-list))) (define (dired-buffer-directory-spec buffer) (or (buffer-get buffer 'DIRED-DIRECTORY-SPEC) diff --git a/src/edwin/display.scm b/src/edwin/display.scm index d3d95ca1a..a6cd0556a 100644 --- a/src/edwin/display.scm +++ b/src/edwin/display.scm @@ -90,7 +90,7 @@ USA. (define (name->display-type name) (let ((display-type - (list-search-positive display-types - (lambda (display-type) - (eq? name (display-type/name display-type)))))) + (find (lambda (display-type) + (eq? name (display-type/name display-type))) + display-types))) display-type)) \ No newline at end of file diff --git a/src/edwin/filcom.scm b/src/edwin/filcom.scm index c385f85e6..6da61accf 100644 --- a/src/edwin/filcom.scm +++ b/src/edwin/filcom.scm @@ -479,9 +479,9 @@ all buffers." (define (pathname->buffer pathname) (let ((pathname (->pathname pathname))) - (list-search-positive (buffer-list) - (lambda (buffer) - (equal? pathname (buffer-pathname buffer)))))) + (find (lambda (buffer) + (equal? pathname (buffer-pathname buffer))) + (buffer-list)))) (define-command set-visited-file-name "Change name of file visited in current buffer. diff --git a/src/edwin/info.scm b/src/edwin/info.scm index 0b7c04fe2..36802a909 100644 --- a/src/edwin/info.scm +++ b/src/edwin/info.scm @@ -457,9 +457,9 @@ except for \\[info-cease-edit] to return to Info." (let ((current-item (current-menu-item (current-point)))) (and current-item (let ((current-index (mark-index current-item))) - (list-search-positive item-alist - (lambda (entry) - (= current-index (cdr entry))))))))) + (find (lambda (entry) + (= current-index (cdr entry))) + item-alist)))))) (if current-entry (prompt-for-alist-value "Menu item" item-alist @@ -858,9 +858,9 @@ The name may be an abbreviation of the reference name." (for-each (lambda (submenu) (let ((nodename (car submenu))) - (if (not (or (list-search-positive menu-items - (lambda (item) - (string-ci=? item nodename))) + (if (not (or (find (lambda (item) + (string-ci=? item nodename)) + menu-items) (re-search-forward (string-append "^\\* " (re-quote-string nodename) diff --git a/src/edwin/keymap.scm b/src/edwin/keymap.scm index 793fa8aac..a71e8df2e 100644 --- a/src/edwin/keymap.scm +++ b/src/edwin/keymap.scm @@ -162,9 +162,9 @@ Previous contents of that buffer are killed first." (let ((make-entry (lambda (prefix element) (let ((entry - (list-search-positive prefix-alist - (lambda (entry) - (string=? (car entry) prefix))))) + (find (lambda (entry) + (string=? (car entry) prefix)) + prefix-alist))) (if entry (set-cdr! entry (cons element (cdr entry))) (set! prefix-alist diff --git a/src/edwin/snr.scm b/src/edwin/snr.scm index 4b30027cf..a7d90bcaa 100644 --- a/src/edwin/snr.scm +++ b/src/edwin/snr.scm @@ -398,10 +398,10 @@ Only one News reader may be open per server; if a previous News reader ;;;; News-Server Buffer (define (find-news-server-buffer server) - (list-search-positive (buffer-list) - (lambda (buffer) - (and (news-server-buffer? buffer) - (string-ci=? (news-server-buffer:server buffer) server))))) + (find (lambda (buffer) + (and (news-server-buffer? buffer) + (string-ci=? (news-server-buffer:server buffer) server))) + (buffer-list))) (define (make-news-server-buffer server) (create-news-buffer (news-buffer-name server "subscribed-groups") diff --git a/src/edwin/unix.scm b/src/edwin/unix.scm index b4841b8f9..93521f946 100644 --- a/src/edwin/unix.scm +++ b/src/edwin/unix.scm @@ -657,9 +657,8 @@ option, instead taking -P ." set-file-modes!) (define (os/rmail-spool-directory) - (or (list-search-positive - '("/var/spool/mail/" "/var/mail/" "/usr/spool/mail/" "/usr/mail/") - file-directory?) + (or (find file-directory? + '("/var/spool/mail/" "/var/mail/" "/usr/spool/mail/" "/usr/mail/")) "/usr/spool/mail/")) (define (os/rmail-primary-inbox-list system-mailboxes) diff --git a/src/edwin/vc.scm b/src/edwin/vc.scm index 9ba335706..2eaa5e170 100644 --- a/src/edwin/vc.scm +++ b/src/edwin/vc.scm @@ -921,11 +921,11 @@ Normally shows only locked files; prefix arg says to show all files." buffer)) (define (get-vc-dired-buffer directory) - (or (list-search-positive (buffer-list) - (lambda (buffer) - (let ((spec (buffer-get buffer 'VC-DIRECTORY-SPEC #f))) - (and spec - (pathname=? (car spec) directory))))) + (or (find (lambda (buffer) + (let ((spec (buffer-get buffer 'VC-DIRECTORY-SPEC #f))) + (and spec + (pathname=? (car spec) directory)))) + (buffer-list)) (new-buffer (pathname->buffer-name directory)))) (define (fill-vc-dired-buffer! buffer directory all-files?) diff --git a/src/edwin/win32.scm b/src/edwin/win32.scm index b84c76eb8..8cf5ddce0 100644 --- a/src/edwin/win32.scm +++ b/src/edwin/win32.scm @@ -247,8 +247,8 @@ USA. (error "Screen has unexpectedly vanished" screen))) (define (handle->win32-screen handle) - (list-search-positive win32-screens - (lambda (screen) (eqv? handle (state/handle (screen-state screen)))))) + (find (lambda (screen) (eqv? handle (state/handle (screen-state screen)))) + win32-screens)) (define-integrable (screen-name screen) (state/name (screen-state screen))) diff --git a/src/imail/imail-browser.scm b/src/imail/imail-browser.scm index 964d30b5b..2a4c931f9 100644 --- a/src/imail/imail-browser.scm +++ b/src/imail/imail-browser.scm @@ -32,9 +32,9 @@ USA. (select-buffer (get-imail-browser-buffer url))) (define (get-imail-browser-buffer url) - (or (list-search-positive (buffer-list) - (lambda (buffer) - (eq? (selected-container-url #f buffer) url))) + (or (find (lambda (buffer) + (eq? (selected-container-url #f buffer) url)) + (buffer-list)) (let ((container (open-resource url)) (buffer (new-buffer diff --git a/src/imail/imail-imap.scm b/src/imail/imail-imap.scm index f3be5b242..d8acca172 100644 --- a/src/imail/imail-imap.scm +++ b/src/imail/imail-imap.scm @@ -1161,9 +1161,9 @@ USA. (define (imail-flag->imap-flag flag) (let ((entry - (list-search-positive standard-imap-flags - (lambda (entry) - (string-ci=? flag (cdr entry)))))) + (find (lambda (entry) + (string-ci=? flag (cdr entry))) + standard-imap-flags))) (if entry (car entry) (intern flag)))) diff --git a/src/imail/imail-top.scm b/src/imail/imail-top.scm index 8afbfeb62..b7433c480 100644 --- a/src/imail/imail-top.scm +++ b/src/imail/imail-top.scm @@ -2073,9 +2073,9 @@ WARNING: With a prefix argument, this command may take a very long (and error? (error:bad-range-argument folder 'IMAIL-FOLDER->BUFFER)))) (define (imail-message->buffer message error?) - (or (list-search-positive (buffer-list) - (lambda (buffer) - (eq? (buffer-get buffer 'IMAIL-MESSAGE #f) message))) + (or (find (lambda (buffer) + (eq? (buffer-get buffer 'IMAIL-MESSAGE #f) message)) + (buffer-list)) (and error? (error:bad-range-argument message 'IMAIL-MESSAGE->BUFFER)))) (define (associate-buffer-with-imail-buffer folder-buffer buffer) diff --git a/src/imail/imap-response.scm b/src/imail/imap-response.scm index df690348a..1de18222d 100644 --- a/src/imail/imap-response.scm +++ b/src/imail/imap-response.scm @@ -655,16 +655,16 @@ USA. (define (imap:response:fetch-body-part response section offset) (let ((entry - (list-search-positive (cddr response) - (lambda (entry) - (and (eq? (car entry) 'BODY) - (equal? (cadr entry) section) - (pair? (cddr entry)) - (eqv? offset (caddr entry)) - (pair? (cdddr entry)) - (or (not (cadddr entry)) - (string? (cadddr entry))) - (null? (cddddr entry))))))) + (find (lambda (entry) + (and (eq? (car entry) 'BODY) + (equal? (cadr entry) section) + (pair? (cddr entry)) + (eqv? offset (caddr entry)) + (pair? (cdddr entry)) + (or (not (cadddr entry)) + (string? (cadddr entry))) + (null? (cddddr entry)))) + (cddr response)))) (if (not entry) (error "Missing FETCH body part:" section offset)) (cadddr entry))) diff --git a/src/sos/class.scm b/src/sos/class.scm index ed740dc7c..52ae781dd 100644 --- a/src/sos/class.scm +++ b/src/sos/class.scm @@ -114,9 +114,9 @@ USA. (class/slots (guarantee-class class 'CLASS-SLOTS))) (define (class-slot class name error?) - (or (list-search-positive (class/slots (guarantee-class class 'CLASS-SLOT)) - (lambda (slot) - (eq? name (slot-name slot)))) + (or (find (lambda (slot) + (eq? name (slot-name slot))) + (class/slots (guarantee-class class 'CLASS-SLOT))) (and error? (class-slot class (error:no-such-slot class name) error?)))) diff --git a/src/sos/method.scm b/src/sos/method.scm index 0a4a25bdb..7fe7a711d 100644 --- a/src/sos/method.scm +++ b/src/sos/method.scm @@ -105,8 +105,8 @@ USA. (define (method-combinator-record generic intern?) (let ((combinator - (or (list-search-positive (generic-procedure-generator-list generic) - method-combinator?) + (or (find method-combinator? + (generic-procedure-generator-list generic)) (and intern? (let ((combinator (make-method-combinator))) (add-generic-procedure-generator generic combinator) diff --git a/src/sos/slot.scm b/src/sos/slot.scm index 77a776d92..474412796 100644 --- a/src/sos/slot.scm +++ b/src/sos/slot.scm @@ -183,9 +183,9 @@ USA. (for-each (lambda (x) (let ((names - (or (list-search-positive interacting-options - (lambda (names) - (memq (car x) names))) + (or (find (lambda (names) + (memq (car x) names)) + interacting-options) (list (car x))))) (let ((entry (let loop ((names names))