From 7ee7d63eeb320a9590165b2a067ada9992aa1393 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sun, 15 Apr 2018 00:49:20 -0700 Subject: [PATCH] Eliminate references to various list filters in favor of SRFI-1. One unfortunate development is that somewhere in the compiler is some code that depends on the result of a filtering option being newly allocated, while FILTER shares the tail of the input list when it can. I modified FILTER to stop doing that, because it wasn't obvious which of the modified calls in the compiler was causing the problem. --- src/6001/floppy.scm | 7 +- src/compiler/back/lapgn1.scm | 10 +- src/compiler/back/mermap.scm | 23 ++-- src/compiler/back/regmap.scm | 10 +- src/compiler/base/infnew.scm | 8 +- src/compiler/base/lvalue.scm | 10 +- src/compiler/base/toplev.scm | 22 ++-- src/compiler/base/utils.scm | 6 +- src/compiler/fggen/declar.scm | 7 +- src/compiler/fgopt/blktyp.scm | 39 +++---- src/compiler/fgopt/closan.scm | 53 ++++----- src/compiler/fgopt/envopt.scm | 3 +- src/compiler/fgopt/folcon.scm | 68 +++++------ src/compiler/fgopt/param.scm | 28 ++--- src/compiler/fgopt/reteqv.scm | 24 ++-- src/compiler/fgopt/reuse.scm | 20 ++-- src/compiler/fgopt/sideff.scm | 71 ++++++------ src/compiler/fgopt/subfre.scm | 4 +- src/compiler/machines/C/decls.scm | 15 ++- src/compiler/machines/C/traditional.scm | 14 +-- src/compiler/machines/i386/decls.scm | 15 ++- .../machines/svm/assembler-compiler.scm | 19 ++- src/compiler/machines/svm/decls.scm | 15 ++- src/compiler/machines/x86-64/decls.scm | 15 ++- src/compiler/rtlbase/rgraph.scm | 6 +- src/compiler/rtlbase/rtlcon.scm | 17 +-- src/compiler/rtlgen/opncod.scm | 8 +- src/compiler/rtlgen/rgrval.scm | 7 +- src/compiler/rtlgen/rtlgen.scm | 6 +- src/compiler/rtlopt/rinvex.scm | 45 ++++---- src/compiler/rtlopt/rtlcsm.scm | 4 +- src/cref/conpkg.scm | 22 ++-- src/cref/forpkg.scm | 21 ++-- src/edwin/autosv.scm | 12 +- src/edwin/comtab.scm | 23 ++-- src/edwin/debug.scm | 11 +- src/edwin/display.scm | 2 +- src/edwin/dos.scm | 13 ++- src/edwin/filcom.scm | 28 ++--- src/edwin/keymap.scm | 6 +- src/edwin/nntp.scm | 40 +++---- src/edwin/prompt.scm | 22 ++-- src/edwin/rfc822.scm | 8 +- src/edwin/snr.scm | 18 +-- src/imail/imail-browser.scm | 8 +- src/imail/imail-core.scm | 6 +- src/imail/imail-imap.scm | 12 +- src/imail/imail-top.scm | 47 ++++---- src/imail/imail-util.scm | 4 +- src/microcode/makegen/makegen.scm | 18 +-- src/runtime/defstr.scm | 8 +- src/runtime/environment.scm | 27 +++-- src/runtime/graphics.scm | 2 +- src/runtime/list.scm | 108 ++---------------- src/runtime/regexp.scm | 2 +- src/runtime/rep.scm | 2 +- src/runtime/srfi-1.scm | 24 ++-- src/runtime/stack-sample.scm | 4 +- src/runtime/textual-port.scm | 24 ++-- src/runtime/unxdir.scm | 12 +- src/runtime/xeval.scm | 51 +++++---- src/sos/instance.scm | 16 +-- src/sos/method.scm | 25 ++-- src/star-parser/shared.scm | 34 +++--- src/xdoc/xdoc.scm | 22 ++-- src/xml/xpath.scm | 6 +- 66 files changed, 587 insertions(+), 700 deletions(-) diff --git a/src/6001/floppy.scm b/src/6001/floppy.scm index 1adeec2d4..f1080e11f 100644 --- a/src/6001/floppy.scm +++ b/src/6001/floppy.scm @@ -505,13 +505,12 @@ otherwise answer \"no\" to leave these files on your floppy. (make-file-record (file-namestring pathname) (* (quotient (file-modification-time pathname) 60) 60))) - (list-transform-negative (directory-read student-work-directory) - file-directory?))) + (remove file-directory? (directory-read student-work-directory)))) (valid-dos-record? (lambda (record) (valid-dos-filename? (file-record/name record))))) (append-string "done") - (let ((non-dos (list-transform-negative result valid-dos-record?))) + (let ((non-dos (remove valid-dos-record? result))) (if (null? non-dos) result (begin @@ -549,7 +548,7 @@ M-x rename-file, or use the `r' command in Dired.") (append-string " ----------------------------------------------------------------------") - (list-transform-positive result valid-dos-record?)))))))) + (filter valid-dos-record? result)))))))) (define-command describe-dos-filenames "Describe the format of DOS filenames." diff --git a/src/compiler/back/lapgn1.scm b/src/compiler/back/lapgn1.scm index 7d2e23868..0ec84e16b 100644 --- a/src/compiler/back/lapgn1.scm +++ b/src/compiler/back/lapgn1.scm @@ -68,7 +68,7 @@ USA. (vector-ref remote-link 0))) unspecific) remote-links)) - + (with-values prepare-constants-block (or process-constants-block (lambda (constants-code environment-label free-ref-label @@ -139,9 +139,7 @@ USA. (or (assq next *pending-bblocks*) (let ((entry (cons next - (list-transform-positive - previous - edge-left-node)))) + (filter edge-left-node previous)))) (set! *pending-bblocks* (cons entry *pending-bblocks*)) @@ -194,9 +192,7 @@ USA. (loop))))))) (define (adjust-maps-at-merge! bblock) - (let ((edges - (list-transform-positive (node-previous-edges bblock) - edge-left-node))) + (let ((edges (filter edge-left-node (node-previous-edges bblock)))) (let ((maps (map (let ((live-registers (bblock-live-at-entry bblock))) diff --git a/src/compiler/back/mermap.scm b/src/compiler/back/mermap.scm index 3736ffb69..289b7bc6f 100644 --- a/src/compiler/back/mermap.scm +++ b/src/compiler/back/mermap.scm @@ -51,14 +51,15 @@ USA. ;; Keep only the aliases with the maximum weights. Furthermore, ;; keep only one alias of a given type. (vector-set! entry 2 - (list-transform-positive alias-weights - (let ((types '())) - (lambda (alias-weight) - (and (= (cdr alias-weight) maximum) - (let ((type (register-type (car alias-weight)))) - (and (not (memq type types)) - (begin (set! types (cons type types)) - true))))))))))) + (filter (let ((types '())) + (lambda (alias-weight) + (and (= (cdr alias-weight) maximum) + (let ((type + (register-type (car alias-weight)))) + (and (not (memq type types)) + (begin (set! types (cons type types)) + true)))))) + alias-weights))))) (define (eliminate-conflicting-aliases! entries) (for-each (lambda (conflicting-alias) @@ -94,9 +95,9 @@ USA. (cons (list (car alias-weight) element) alist))))) (vector-ref entry 2)))) entries) - (list-transform-negative alist - (lambda (alist-entry) - (null? (cddr alist-entry)))))) + (remove (lambda (alist-entry) + (null? (cddr alist-entry))) + alist))) (define (map->weighted-entries register-map weight) (map (lambda (entry) diff --git a/src/compiler/back/regmap.scm b/src/compiler/back/regmap.scm index b714e745b..c4e8693f7 100644 --- a/src/compiler/back/regmap.scm +++ b/src/compiler/back/regmap.scm @@ -194,10 +194,10 @@ registers into some interesting sorting order. (not (memv alias needed-registers)))))) (define (map-entry:aliases entry type needed-registers) - (list-transform-positive (map-entry-aliases entry) - (lambda (alias) - (and (register-type? alias type) - (not (memv alias needed-registers)))))) + (filter (lambda (alias) + (and (register-type? alias type) + (not (memv alias needed-registers)))) + (map-entry-aliases entry))) (define (map-entry:add-alias entry alias) (make-map-entry (map-entry-home entry) @@ -338,7 +338,7 @@ registers into some interesting sorting order. (define (map-equal? x y) (let loop ((x-entries (map-entries x)) - (y-entries (list-transform-positive (map-entries y) map-entry-home))) + (y-entries (filter map-entry-home (map-entries y)))) (cond ((null? x-entries) (null? y-entries)) ((not (map-entry-home (car x-entries))) diff --git a/src/compiler/base/infnew.scm b/src/compiler/base/infnew.scm index 03e29207c..ef3ec68cb 100644 --- a/src/compiler/base/infnew.scm +++ b/src/compiler/base/infnew.scm @@ -333,10 +333,10 @@ USA. (if (null? (cdr names)) (car names) (let ((distinguished - (list-transform-negative names - (lambda (name) - (or (standard-name? name "label") - (standard-name? name "end-label")))))) + (remove (lambda (name) + (or (standard-name? name "label") + (standard-name? name "end-label"))) + names))) (cond ((null? distinguished) (min-suffix names)) ((null? (cdr distinguished)) diff --git a/src/compiler/base/lvalue.scm b/src/compiler/base/lvalue.scm index ebfd3c98d..2f9a4f8f4 100644 --- a/src/compiler/base/lvalue.scm +++ b/src/compiler/base/lvalue.scm @@ -285,14 +285,12 @@ USA. (car source-set)))) (define (lvalue/source-set lvalue) - (list-transform-positive - (eq-set-adjoin lvalue (lvalue-backward-links lvalue)) - lvalue/source?)) + (filter lvalue/source? + (eq-set-adjoin lvalue (lvalue-backward-links lvalue)))) (define (lvalue/external-source-set lvalue) - (list-transform-positive - (eq-set-adjoin lvalue (lvalue-backward-links lvalue)) - lvalue/external-source?)) + (filter lvalue/external-source? + (eq-set-adjoin lvalue (lvalue-backward-links lvalue)))) (define (lvalue/source? lvalue) (or (lvalue/external-source? lvalue) diff --git a/src/compiler/base/toplev.scm b/src/compiler/base/toplev.scm index cf9a05b26..203c7bb9a 100644 --- a/src/compiler/base/toplev.scm +++ b/src/compiler/base/toplev.scm @@ -52,15 +52,16 @@ USA. (let ((output-time (file-modification-time output-file))) (if (not output-time) (list input-file) - (list-transform-positive (cons input-file dependencies) - (lambda (dependency) - (let ((dep-time (file-modification-time dependency))) - (if dep-time - (> dep-time output-time) - (begin - (warn "Missing dependency:" - (->namestring dependency)) - #f))))))))) + (filter (lambda (dependency) + (let ((dep-time + (file-modification-time dependency))) + (if dep-time + (> dep-time output-time) + (begin + (warn "Missing dependency:" + (->namestring dependency)) + #f)))) + (cons input-file dependencies)))))) (if (pair? reasons) (begin (write-notification-line @@ -95,8 +96,7 @@ USA. (sf/default-declarations `((USUAL-INTEGRATIONS ,@compile-file:override-usual-integrations) - ,@(let ((deps (keep-matching-items - dependencies ext-pathname?))) + ,@(let ((deps (filter ext-pathname? dependencies))) (if (null? deps) '() `((INTEGRATE-EXTERNAL ,@deps))))))) diff --git a/src/compiler/base/utils.scm b/src/compiler/base/utils.scm index b600f5834..27aad9417 100644 --- a/src/compiler/base/utils.scm +++ b/src/compiler/base/utils.scm @@ -428,9 +428,9 @@ USA. (let ((global-valued (lambda (names) - (list-transform-negative names - (lambda (name) - (lexical-unreferenceable? system-global-environment name))))) + (remove (lambda (name) + (lexical-unreferenceable? system-global-environment name)) + names))) (global-value (lambda (name) (lexical-reference system-global-environment name)))) diff --git a/src/compiler/fggen/declar.scm b/src/compiler/fggen/declar.scm index e55f5ade0..ac8b21369 100644 --- a/src/compiler/fggen/declar.scm +++ b/src/compiler/fggen/declar.scm @@ -121,10 +121,9 @@ USA. (cond ((eq? specification 'BOUND) (block-bound-variables block)) ((eq? specification 'FREE) (block-free-variables block)) ((eq? specification 'ASSIGNED) - (list-transform-positive - (append (block-bound-variables block) - (block-free-variables block)) - variable-assigned?)) + (filter variable-assigned? + (append (block-bound-variables block) + (block-free-variables block)))) ((eq? specification 'NONE) '()) ((eq? specification 'ALL) (append (block-bound-variables block) diff --git a/src/compiler/fgopt/blktyp.scm b/src/compiler/fgopt/blktyp.scm index 95b2b8b3a..3d97213c6 100644 --- a/src/compiler/fgopt/blktyp.scm +++ b/src/compiler/fgopt/blktyp.scm @@ -50,7 +50,7 @@ USA. (define (block-type! block type) (set-block-type! block type) (for-each loop (block-children block))) - + (loop root-block) (if compiler:use-multiclosures? (merge-closure-blocks! root-block))) @@ -72,7 +72,7 @@ USA. (examine-children block update?)) (else (error "Illegal block type" block)))) - + (define (examine-children block update?) (for-each (lambda (child) (loop child update?)) @@ -82,10 +82,9 @@ USA. (define (original-block-children block) (append (block-disowned-children block) - (list-transform-positive - (block-children block) - (lambda (block*) - (eq? block (original-block-parent block*)))))) + (filter (lambda (block*) + (eq? block (original-block-parent block*))) + (block-children block)))) (define (maybe-close-procedure! procedure) (if (eq? true (procedure-closure-context procedure)) @@ -109,16 +108,15 @@ USA. value))))))))) (find-closure-bindings original-parent - (list-transform-negative (block-free-variables block) - (lambda (lvalue) - (or (uninteresting-variable? lvalue) - (begin - (set-variable-closed-over?! lvalue true) - false)))) + (remove (lambda (lvalue) + (or (uninteresting-variable? lvalue) + (begin + (set-variable-closed-over?! lvalue true) + false))) + (block-free-variables block)) '() - (list-transform-negative - (block-variables-nontransitively-free block) - uninteresting-variable?)))) + (remove uninteresting-variable? + (block-variables-nontransitively-free block))))) (lambda (closure-block closure-block?) (transfer-block-child! block parent closure-block) (set-procedure-closure-size! @@ -246,12 +244,11 @@ USA. (define (attempt-children-merge block procedure update?) (let ((closure-children - (list-transform-positive - (original-block-children block) - (lambda (block*) - (let ((procedure* (block-procedure block*))) - (and procedure* - (procedure/full-closure? procedure*))))))) + (filter (lambda (block*) + (let ((procedure* (block-procedure block*))) + (and procedure* + (procedure/full-closure? procedure*)))) + (original-block-children block)))) (and (not (null? closure-children)) (list-split closure-children diff --git a/src/compiler/fgopt/closan.scm b/src/compiler/fgopt/closan.scm index 38e74ea88..48084a79b 100644 --- a/src/compiler/fgopt/closan.scm +++ b/src/compiler/fgopt/closan.scm @@ -156,10 +156,8 @@ USA. ;;; is difficult to determine how to make it work well. (define (identify-closure-limits! procs&conts applications lvalues) - (let ((procedures - (delete-matching-items procs&conts procedure-continuation?)) - (combinations - (keep-matching-items applications application/combination?))) + (let ((procedures (remove procedure-continuation? procs&conts)) + (combinations (filter application/combination? applications))) (for-each (lambda (procedure) (set-procedure-variables! procedure '())) procedures) @@ -531,28 +529,31 @@ USA. unspecific) (define (remove-condition-1 procedure constraints) - (delete-matching-items! constraints - (lambda (entry) - (let ((tail - (delete-matching-items! (cdr entry) - (lambda (entry*) - (let ((conditions - (delete-matching-items! (cdr entry*) - (lambda (condition) - (and condition - (or (eq? procedure - (condition-procedure condition)) - (memq procedure - (condition-dependencies condition))) - (begin - (debug:remove-condition (car entry) - (car entry*) - condition) - #t)))))) - (set-cdr! entry* conditions) - (null? conditions)))))) - (set-cdr! entry tail) - (null? tail))))) + (remove! + (lambda (entry) + (let ((tail + (remove! + (lambda (entry*) + (let ((conditions + (remove! (lambda (condition) + (and condition + (or (eq? procedure + (condition-procedure condition)) + (memq procedure + (condition-dependencies + condition))) + (begin + (debug:remove-condition (car entry) + (car entry*) + condition) + #t))) + (cdr entry*)))) + (set-cdr! entry* conditions) + (null? conditions))) + (cdr entry)))) + (set-cdr! entry tail) + (null? tail))) + constraints)) (define (debug:remove-condition block block* condition) (if debug:trace-constraints? diff --git a/src/compiler/fgopt/envopt.scm b/src/compiler/fgopt/envopt.scm index 02811e834..2cb55879a 100644 --- a/src/compiler/fgopt/envopt.scm +++ b/src/compiler/fgopt/envopt.scm @@ -33,8 +33,7 @@ USA. ;; Does this really have to ignore continuations? ;; Is this only because we implement continuations differently? (let ((procedures - (list-transform-negative procedures&continuations - procedure-continuation?))) + (remove procedure-continuation? procedures&continuations))) (if compiler:optimize-environments? (begin (for-each initialize-target-block! procedures) diff --git a/src/compiler/fgopt/folcon.scm b/src/compiler/fgopt/folcon.scm index 2441ee689..ee2410dc9 100644 --- a/src/compiler/fgopt/folcon.scm +++ b/src/compiler/fgopt/folcon.scm @@ -39,10 +39,9 @@ USA. (for-each (lambda (lvalue) (set-lvalue-source-links! lvalue - (list-transform-negative - (lvalue-backward-links lvalue) - (lambda (lvalue*) - (memq lvalue (lvalue-backward-links lvalue*)))))) + (remove (lambda (lvalue*) + (memq lvalue (lvalue-backward-links lvalue*))) + (lvalue-backward-links lvalue)))) lvalues) ;; b. Remove nop nodes (transitive-closure false delete-if-nop! lvalues) @@ -51,7 +50,7 @@ USA. (let loop ((lvalues lvalues) (combinations - (list-transform-positive applications application/combination?))) + (filter application/combination? applications))) (let ((unknown-lvalues (eliminate-known-nodes lvalues))) (transmit-values (fold-combinations combinations) (lambda (any-folded? not-folded) @@ -76,23 +75,24 @@ USA. #| (define (eliminate-known-nodes lvalues) (let ((knowable-nodes - (list-transform-positive lvalues - (lambda (lvalue) - (and (not (or (lvalue-passed-in? lvalue) - (and (variable? lvalue) - (variable-assigned? lvalue) - (not (memq 'CONSTANT - (variable-declarations lvalue)))))) - (let ((values (lvalue-values lvalue))) - (and (not (null? values)) - (null? (cdr values)) - (or (rvalue/procedure? (car values)) - (rvalue/constant? (car values)))))))))) + (filter (lambda (lvalue) + (and (not (or (lvalue-passed-in? lvalue) + (and (variable? lvalue) + (variable-assigned? lvalue) + (not (memq 'CONSTANT + (variable-declarations + lvalue)))))) + (let ((values (lvalue-values lvalue))) + (and (not (null? values)) + (null? (cdr values)) + (or (rvalue/procedure? (car values)) + (rvalue/constant? (car values))))))) + lvalues))) (with-new-lvalue-marks (lambda () (for-each lvalue-mark! knowable-nodes) (transitive-closure false delete-if-known! knowable-nodes)))) - (list-transform-negative lvalues lvalue-known-value)) + (remove lvalue-known-value lvalues)) (define (delete-if-known! lvalue) (if (and (not (lvalue-known-value lvalue)) @@ -106,22 +106,22 @@ USA. |# (define (eliminate-known-nodes lvalues) - (list-transform-negative lvalues - (lambda (lvalue) - (and (not (or (lvalue-passed-in? lvalue) - (and (variable? lvalue) - (variable-assigned? lvalue) - (not (memq 'CONSTANT - (variable-declarations lvalue)))))) - (let ((values (lvalue-values lvalue))) - (and (not (null? values)) - (null? (cdr values)) - (let ((value (car values))) - (and (or (rvalue/procedure? value) - (rvalue/constant? value)) - (begin - (set-lvalue-known-value! lvalue value) - true))))))))) + (remove (lambda (lvalue) + (and (not (or (lvalue-passed-in? lvalue) + (and (variable? lvalue) + (variable-assigned? lvalue) + (not (memq 'CONSTANT + (variable-declarations lvalue)))))) + (let ((values (lvalue-values lvalue))) + (and (not (null? values)) + (null? (cdr values)) + (let ((value (car values))) + (and (or (rvalue/procedure? value) + (rvalue/constant? value)) + (begin + (set-lvalue-known-value! lvalue value) + true))))))) + lvalues)) #| (define (fold-combinations combinations) diff --git a/src/compiler/fgopt/param.scm b/src/compiler/fgopt/param.scm index a6f98b9d9..386319fc5 100644 --- a/src/compiler/fgopt/param.scm +++ b/src/compiler/fgopt/param.scm @@ -73,8 +73,8 @@ parameters in registers. (define (parameter-analysis procedure) (fluid-let ((*inlined-procedures* '())) (let ((interesting-parameters - (list-transform-positive (procedure-required procedure) - interesting-variable?))) + (filter interesting-variable? + (procedure-required procedure)))) (if interesting-parameters (let ((registerizable-parameters (with-new-node-marks @@ -214,13 +214,13 @@ parameters in registers. (interesting-variable? lvalue) (list lvalue))) (map->eq-set (lambda (rvalue) (reference-lvalue rvalue)) - (list-transform-positive rvalues - (lambda (rvalue) - (and (rvalue/reference? rvalue) - (let ((lvalue (reference-lvalue rvalue))) - (and lvalue - (lvalue/variable? lvalue) - (interesting-variable? lvalue))))))))) + (filter (lambda (rvalue) + (and (rvalue/reference? rvalue) + (let ((lvalue (reference-lvalue rvalue))) + (and lvalue + (lvalue/variable? lvalue) + (interesting-variable? lvalue))))) + rvalues)))) (define (complex-parallel-constraints subproblems vars-referenced-later) (with-values (lambda () (discriminate-items subproblems subproblem-simple?)) @@ -256,10 +256,10 @@ parameters in registers. (define (bad-free-variables procedure) (append-map block-variables-nontransitively-free - (list-transform-negative - (cdr (linearize-block-tree (procedure-block procedure))) - (lambda (block) - (memq (block-procedure block) *inlined-procedures*))))) + (remove (lambda (block) + (memq (block-procedure block) *inlined-procedures*)) + (cdr (linearize-block-tree + (procedure-block procedure)))))) ;;; Since the order of this linearization is not important we could ;;; make this routine more efficient. I'm not sure that it is worth @@ -277,7 +277,7 @@ parameters in registers. ;;; variables that will be in cells are eliminated from ;;; being put in registers because I couldn't figure out ;;; how to get the right code generated for them. Oh well, - ;;; sigh! + ;;; sigh! (not (or (variable-assigned? variable) (variable-stack-overwrite-target? variable) (variable/continuation-variable? variable) diff --git a/src/compiler/fgopt/reteqv.scm b/src/compiler/fgopt/reteqv.scm index bf6d67896..0fe8830d2 100644 --- a/src/compiler/fgopt/reteqv.scm +++ b/src/compiler/fgopt/reteqv.scm @@ -41,19 +41,17 @@ USA. return-class)) (append-map (lambda (source) - (list-transform-positive - (node-equivalence-classes - (gmap - (eq-set-adjoin - source - (list-transform-positive (lvalue-forward-links source) - lvalue/unique-source)) - lvalue-applications - eq-set-union) - return=?) - (lambda (class) - (not (null? (cdr class)))))) - (gmap (list-transform-positive lvalues continuation-variable?) + (filter (lambda (class) + (not (null? (cdr class)))) + (node-equivalence-classes + (gmap + (eq-set-adjoin + source + (filter lvalue/unique-source (lvalue-forward-links source))) + lvalue-applications + eq-set-union) + return=?))) + (gmap (filter continuation-variable? lvalues) lvalue/unique-source (lambda (source sources) (if (and source (not (memq source sources))) diff --git a/src/compiler/fgopt/reuse.scm b/src/compiler/fgopt/reuse.scm index 6136f1ec3..4e9e7190a 100644 --- a/src/compiler/fgopt/reuse.scm +++ b/src/compiler/fgopt/reuse.scm @@ -171,11 +171,10 @@ USA. (closure-procedure-needs-operator? procedure)) (list block) '()) - (list-transform-negative - (cdr (procedure-required procedure)) - (lambda (variable) - (or (lvalue-integrated? variable) - (variable-register variable)))) + (remove (lambda (variable) + (or (lvalue-integrated? variable) + (variable-register variable))) + (cdr (procedure-required procedure))) (procedure-optional procedure) (if (procedure-rest procedure) (list (procedure-rest procedure)) '()) (if (and (not (procedure/closure? procedure)) @@ -187,9 +186,9 @@ USA. (let ((block (and (memq overwritten-block targets) overwritten-block))) (if (not block) (lambda (subproblem) - (list-transform-positive (subproblem-free-variables subproblem) - (lambda (variable) - (memq variable targets)))) + (filter (lambda (variable) + (memq variable targets)) + (subproblem-free-variables subproblem))) (lambda (subproblem) (let loop ((variables (subproblem-free-variables subproblem)) @@ -257,9 +256,8 @@ USA. (add-reference-context/adjacent-parents! context blocks))))) (values node (map node-value - (list-transform-negative - (append terminal-nodes reordered-non-terms) - node/noop?))))) + (remove node/noop? + (append terminal-nodes reordered-non-terms)))))) (define (generate-assignments nodes rest) (cond ((null? nodes) diff --git a/src/compiler/fgopt/sideff.scm b/src/compiler/fgopt/sideff.scm index ef00db659..77461c6e5 100644 --- a/src/compiler/fgopt/sideff.scm +++ b/src/compiler/fgopt/sideff.scm @@ -51,9 +51,7 @@ USA. (let* ((operator (application-operator (car apps))) (nconsts (eq-set-union - (list-transform-positive - (rvalue-values operator) - rvalue/constant?) + (filter rvalue/constant? (rvalue-values operator)) constants))) (loop (cdr apps) (if (or (not (rvalue-passed-in? operator)) @@ -66,16 +64,16 @@ USA. (reference-lvalue operator) nconsts)) (eq-set-union - (list-transform-positive - (rvalue-values operator) - #| - ;; This is unnecessary as long as we treat continuations - ;; specially and treat cwcc as an unknown procedure. - (lambda (val) - (and (rvalue/procedure? val) - (not (procedure-continuation? val)))) - |# - rvalue/procedure?) + (filter + #| + ;; This is unnecessary as long as we treat continuations + ;; specially and treat cwcc as an unknown procedure. + (lambda (val) + (and (rvalue/procedure? val) + (not (procedure-continuation? val)))) + |# + rvalue/procedure? + (rvalue-values operator)) procedures))))))) (define-export (clear-call-graph! procedures) @@ -121,8 +119,7 @@ USA. ;; IMPORTANT: This assumes that the call graph has been computed. (define-export (side-effect-analysis procs&conts applications) - (let ((procedures - (list-transform-negative procs&conts procedure-continuation?))) + (let ((procedures (remove procedure-continuation? procs&conts))) (if (not compiler:analyze-side-effects?) (for-each (lambda (proc) (set-procedure-side-effects! @@ -139,28 +136,24 @@ USA. (analyze-combination! item) (analyze-procedure! item))) (append procedures - (list-transform-positive - applications - application/combination?))))))) + (filter application/combination? applications))))))) (define (setup-side-effects! procedure) (let ((assigned-vars (let ((block (procedure-block procedure))) - (list-transform-positive - (block-free-variables block) - (lambda (variable) - (any (lambda (assignment) - (eq? (reference-context/block - (assignment-context assignment)) - block)) - (variable-assignments variable)))))) + (filter (lambda (variable) + (any (lambda (assignment) + (eq? (reference-context/block + (assignment-context assignment)) + block)) + (variable-assignments variable))) + (block-free-variables block)))) (arbitrary-callees - (list-transform-negative - (car (procedure-initial-callees procedure)) - (lambda (object) - (if (lvalue/variable? object) - (variable/side-effect-free? object) - (constant/side-effect-free? object)))))) + (remove (lambda (object) + (if (lvalue/variable? object) + (variable/side-effect-free? object) + (constant/side-effect-free? object))) + (car (procedure-initial-callees procedure))))) (set-procedure-side-effects! procedure `(,@(if (null? assigned-vars) @@ -189,13 +182,13 @@ USA. (define (process-derived-assignments! procedure variables effects) (let* ((block (procedure-block procedure)) (modified-variables - (list-transform-negative - variables - (lambda (var) - ;; The theoretical closing limit of this variable would be give - ;; a more precise bound, but we don't have that information. - (and (not (variable-closed-over? var)) - (block-ancestor-or-self? (variable-block var) block)))))) + (remove (lambda (var) + ;; The theoretical closing limit of this variable would be + ;; give a more precise bound, but we don't have that + ;; information. + (and (not (variable-closed-over? var)) + (block-ancestor-or-self? (variable-block var) block))) + variables))) (if (null? modified-variables) effects (let ((place (assq 'DERIVED-ASSIGNMENT effects))) diff --git a/src/compiler/fgopt/subfre.scm b/src/compiler/fgopt/subfre.scm index 97de38fcb..5859a822a 100644 --- a/src/compiler/fgopt/subfre.scm +++ b/src/compiler/fgopt/subfre.scm @@ -66,9 +66,7 @@ USA. (define (walk-procedure proc) (define (default) - (list-transform-negative - (block-free-variables (procedure-block proc)) - lvalue-integrated?)) + (remove lvalue-integrated? (block-free-variables (procedure-block proc)))) (define (closure) (eq-set-union diff --git a/src/compiler/machines/C/decls.scm b/src/compiler/machines/C/decls.scm index d284bfbbf..c4db0038d 100644 --- a/src/compiler/machines/C/decls.scm +++ b/src/compiler/machines/C/decls.scm @@ -148,14 +148,14 @@ USA. (for-each (lambda (node) (set-source-node/dependencies! node - (list-transform-negative (source-node/backward-closure node) - (lambda (node*) - (memq node (source-node/backward-closure node*))))) + (remove (lambda (node*) + (memq node (source-node/backward-closure node*))) + (source-node/backward-closure node))) (set-source-node/dependents! node - (list-transform-negative (source-node/forward-closure node) - (lambda (node*) - (memq node (source-node/forward-closure node*)))))) + (remove (lambda (node*) + (memq node (source-node/forward-closure node*))) + (source-node/forward-closure node)))) nodes)) (define (compute-ranks! nodes) @@ -314,8 +314,7 @@ USA. ((if compiler:enable-integration-declarations? identity-procedure (lambda (declarations) - (list-transform-negative declarations - integration-declaration?))) + (remove integration-declaration? declarations))) (source-node/declarations node))))) (define (modification-time node type) diff --git a/src/compiler/machines/C/traditional.scm b/src/compiler/machines/C/traditional.scm index 38f125f5e..4ce88c401 100644 --- a/src/compiler/machines/C/traditional.scm +++ b/src/compiler/machines/C/traditional.scm @@ -50,13 +50,13 @@ USA. (define (build-table nodes) (map cdr (sort (sort/enumerate - (keep-matching-items - (let loop ((nodes nodes) (table '())) - (if (pair? nodes) - (loop (cdr nodes) - (insert-in-table (car nodes) 0 table)) - table)) - cdr)) + (filter + cdr + (let loop ((nodes nodes) (table '())) + (if (pair? nodes) + (loop (cdr nodes) + (insert-in-table (car nodes) 0 table)) + table)))) (lambda (entry1 entry2) (let ((obj1 (cadr entry1)) (obj2 (cadr entry2))) diff --git a/src/compiler/machines/i386/decls.scm b/src/compiler/machines/i386/decls.scm index e45fbc2ad..42dbd9c47 100644 --- a/src/compiler/machines/i386/decls.scm +++ b/src/compiler/machines/i386/decls.scm @@ -148,14 +148,14 @@ USA. (for-each (lambda (node) (set-source-node/dependencies! node - (list-transform-negative (source-node/backward-closure node) - (lambda (node*) - (memq node (source-node/backward-closure node*))))) + (remove (lambda (node*) + (memq node (source-node/backward-closure node*))) + (source-node/backward-closure node))) (set-source-node/dependents! node - (list-transform-negative (source-node/forward-closure node) - (lambda (node*) - (memq node (source-node/forward-closure node*)))))) + (remove (lambda (node*) + (memq node (source-node/forward-closure node*))) + (source-node/forward-closure node)))) nodes)) (define (compute-ranks! nodes) @@ -314,8 +314,7 @@ USA. ((if compiler:enable-integration-declarations? identity-procedure (lambda (declarations) - (list-transform-negative declarations - integration-declaration?))) + (remove integration-declaration? declarations))) (source-node/declarations node))))) (define (modification-time node type) diff --git a/src/compiler/machines/svm/assembler-compiler.scm b/src/compiler/machines/svm/assembler-compiler.scm index 2ac1c1c1a..1e9690e44 100644 --- a/src/compiler/machines/svm/assembler-compiler.scm +++ b/src/compiler/machines/svm/assembler-compiler.scm @@ -39,7 +39,7 @@ USA. (check-coding-types coding-types) (expand-implicit-coding-types coding-types) (let ((explicit - (keep-matching-items coding-types coding-type-explicit?))) + (filter coding-type-explicit? coding-types))) (check-coding-types explicit) (check-code-allocations explicit) (for-each (lambda (coding-type) @@ -195,9 +195,9 @@ USA. nodes) ;; Check for single root. (let ((roots - (keep-matching-items nodes - (lambda (node) - (null? (vector-ref node 2)))))) + (filter (lambda (node) + (null? (vector-ref node 2))) + nodes))) (if (not (pair? roots)) (error "No roots in coding-type graph.")) (if (pair? (cdr roots)) @@ -400,8 +400,7 @@ USA. (assign-defn-codes type))))) (define (independent-coding-type? type coding-types) - (let ((implicit-types - (delete-matching-items coding-types coding-type-explicit?))) + (let ((implicit-types (remove coding-type-explicit? coding-types))) (every (lambda (defn) (not (any (lambda (pv) (find-coding-type (pvar-type pv) implicit-types #f)) @@ -533,8 +532,8 @@ USA. (let ((defn (car defns))) (set-defn-name! defn - (delete-matching-items! (defn-name defn) - deleteable-name-item?))))) + (remove! deleteable-name-item? + (defn-name defn)))))) (group-defns-by-prefix defns)) ;; Join name items into hyphen-separated symbols. (for-each (lambda (defn) @@ -791,8 +790,8 @@ USA. (write-string ", " port) (write-c-name (defn-name defn) #f port) (write-string ")" port)) - (keep-matching-items (coding-type-defns coding-type) - defn-has-code?) + (filter defn-has-code? + (coding-type-defns coding-type)) port)) (define (write-c-opcode+decoder prefix defn port) diff --git a/src/compiler/machines/svm/decls.scm b/src/compiler/machines/svm/decls.scm index 4c4332b9b..161baf847 100644 --- a/src/compiler/machines/svm/decls.scm +++ b/src/compiler/machines/svm/decls.scm @@ -156,14 +156,14 @@ USA. (for-each (lambda (node) (set-source-node/dependencies! node - (list-transform-negative (source-node/backward-closure node) - (lambda (node*) - (memq node (source-node/backward-closure node*))))) + (remove (lambda (node*) + (memq node (source-node/backward-closure node*))) + (source-node/backward-closure node))) (set-source-node/dependents! node - (list-transform-negative (source-node/forward-closure node) - (lambda (node*) - (memq node (source-node/forward-closure node*)))))) + (remove (lambda (node*) + (memq node (source-node/forward-closure node*))) + (source-node/forward-closure node)))) nodes)) (define (compute-ranks! nodes) @@ -322,8 +322,7 @@ USA. ((if compiler:enable-integration-declarations? identity-procedure (lambda (declarations) - (list-transform-negative declarations - integration-declaration?))) + (remove integration-declaration? declarations))) (source-node/declarations node))))) (define (modification-time node type) diff --git a/src/compiler/machines/x86-64/decls.scm b/src/compiler/machines/x86-64/decls.scm index ab7797b97..d568abb94 100644 --- a/src/compiler/machines/x86-64/decls.scm +++ b/src/compiler/machines/x86-64/decls.scm @@ -148,14 +148,14 @@ USA. (for-each (lambda (node) (set-source-node/dependencies! node - (list-transform-negative (source-node/backward-closure node) - (lambda (node*) - (memq node (source-node/backward-closure node*))))) + (remove (lambda (node*) + (memq node (source-node/backward-closure node*))) + (source-node/backward-closure node))) (set-source-node/dependents! node - (list-transform-negative (source-node/forward-closure node) - (lambda (node*) - (memq node (source-node/forward-closure node*)))))) + (remove (lambda (node*) + (memq node (source-node/forward-closure node*))) + (source-node/forward-closure node)))) nodes)) (define (compute-ranks! nodes) @@ -314,8 +314,7 @@ USA. ((if compiler:enable-integration-declarations? identity-procedure (lambda (declarations) - (list-transform-negative declarations - integration-declaration?))) + (remove integration-declaration? declarations))) (source-node/declarations node))))) (define (modification-time node type) diff --git a/src/compiler/rtlbase/rgraph.scm b/src/compiler/rtlbase/rgraph.scm index d5a7b4560..d07316315 100644 --- a/src/compiler/rtlbase/rgraph.scm +++ b/src/compiler/rtlbase/rgraph.scm @@ -58,6 +58,6 @@ USA. (define *current-rgraph*) (define (rgraph-initial-edges rgraph) - (list-transform-positive (rgraph-entry-edges rgraph) - (lambda (edge) - (node-previous=0? (edge-right-node edge))))) \ No newline at end of file + (filter (lambda (edge) + (node-previous=0? (edge-right-node edge))) + (rgraph-entry-edges rgraph))) \ No newline at end of file diff --git a/src/compiler/rtlbase/rtlcon.scm b/src/compiler/rtlbase/rtlcon.scm index 10362d144..e63b94c73 100644 --- a/src/compiler/rtlbase/rtlcon.scm +++ b/src/compiler/rtlbase/rtlcon.scm @@ -433,7 +433,7 @@ USA. (define-expression-method 'ADDRESS (address-method (lambda (receiver scfg-append!) - scfg-append! ;ignore + (declare (ignore scfg-append!)) (lambda (address offset granularity) (receiver (case granularity @@ -548,8 +548,9 @@ USA. (lambda (type) (if use-pre/post-increment? (assign-to-temporary - (rtl:make-offset-address free - (rtl:make-machine-constant (- nelements))) + (rtl:make-offset-address + free + (rtl:make-machine-constant (- nelements))) scfg-append! (lambda (temporary) (receiver (rtl:make-cons-pointer type temporary)))) @@ -600,11 +601,11 @@ USA. (begin (set! reg-list available-machine-registers) (set! value - (length (list-transform-positive reg-list - (lambda (reg) - (value-class/ancestor-or-self? - (machine-register-value-class reg) - value-class=word))))) + (length (filter (lambda (reg) + (value-class/ancestor-or-self? + (machine-register-value-class reg) + value-class=word)) + reg-list))) value))))) (define-expression-method 'TYPED-CONS:PROCEDURE diff --git a/src/compiler/rtlgen/opncod.scm b/src/compiler/rtlgen/opncod.scm index 8da250000..55f9b8730 100644 --- a/src/compiler/rtlgen/opncod.scm +++ b/src/compiler/rtlgen/opncod.scm @@ -295,10 +295,10 @@ USA. (define (open-code:with-checks combination checks non-error-cfg error-finish primitive-name expressions) (let ((checks - (list-transform-negative checks - (lambda (cfg) - (or (cfg-null? cfg) - (pcfg-true? cfg)))))) + (remove (lambda (cfg) + (or (cfg-null? cfg) + (pcfg-true? cfg))) + checks))) (if (null? checks) non-error-cfg ;; Don't generate `error-cfg' unless it is needed. Otherwise diff --git a/src/compiler/rtlgen/rgrval.scm b/src/compiler/rtlgen/rgrval.scm index 9395d1635..e64efa17b 100644 --- a/src/compiler/rtlgen/rgrval.scm +++ b/src/compiler/rtlgen/rgrval.scm @@ -307,10 +307,9 @@ USA. (map (lambda (block) (block-procedure (car (block-children block)))) - (list-transform-negative - (block-grafted-blocks block*) - (lambda (block) - (zero? (block-entry-number block)))))))) + (remove (lambda (block) + (zero? (block-entry-number block))) + (block-grafted-blocks block*)))))) ;; Official entry point. (cons procedure children))) (entries diff --git a/src/compiler/rtlgen/rtlgen.scm b/src/compiler/rtlgen/rtlgen.scm index 11171dd25..933a5e62e 100644 --- a/src/compiler/rtlgen/rtlgen.scm +++ b/src/compiler/rtlgen/rtlgen.scm @@ -50,9 +50,9 @@ USA. (let ((expression (generate/expression expression))) (queue-map!/unsafe *generation-queue* (lambda (thunk) (thunk))) (let ((rgraphs - (list-transform-positive (reverse! *rgraphs*) - (lambda (rgraph) - (not (null? (rgraph-entry-edges rgraph))))))) + (filter (lambda (rgraph) + (not (null? (rgraph-entry-edges rgraph)))) + (reverse! *rgraphs*)))) (for-each (lambda (rgraph) (rgraph/compress! rgraph) (rgraph/postcompress! rgraph)) diff --git a/src/compiler/rtlopt/rinvex.scm b/src/compiler/rtlopt/rinvex.scm index ae8dc5925..e9b885645 100644 --- a/src/compiler/rtlopt/rinvex.scm +++ b/src/compiler/rtlopt/rinvex.scm @@ -123,10 +123,10 @@ USA. (define (optimize-expression expression) (let loop ((identities - (list-transform-positive identities - (let ((type (rtl:expression-type expression))) - (lambda (identity) - (eq? type (car (cadr identity)))))))) + (filter (let ((type (rtl:expression-type expression))) + (lambda (identity) + (eq? type (car (cadr identity))))) + identities))) (cond ((null? identities) expression) ((let ((identity (car identities))) @@ -233,23 +233,26 @@ USA. (set-register-value! register false))))) (for-each (lambda (type) - (define-general-method type (lambda (statement) statement unspecific))) - '(CLOSURE-HEADER - CONTINUATION-ENTRY - CONTINUATION-HEADER - IC-PROCEDURE-HEADER - INVOCATION:APPLY - INVOCATION:COMPUTED-JUMP - INVOCATION:COMPUTED-LEXPR - INVOCATION:JUMP - INVOCATION:LEXPR - INVOCATION:PRIMITIVE - INVOCATION:UUO-LINK - INVOCATION:GLOBAL-LINK - OPEN-PROCEDURE-HEADER - OVERFLOW-TEST - POP-RETURN - PROCEDURE-HEADER)) + (define-general-method type + (lambda (statement) + (declare (ignore statement)) + unspecific))) + '(closure-header + continuation-entry + continuation-header + ic-procedure-header + invocation:apply + invocation:computed-jump + invocation:computed-lexpr + invocation:jump + invocation:lexpr + invocation:primitive + invocation:uuo-link + invocation:global-link + open-procedure-header + overflow-test + pop-return + procedure-header)) (define (define-one-arg-method type get set) (define-general-method type diff --git a/src/compiler/rtlopt/rtlcsm.scm b/src/compiler/rtlopt/rtlcsm.scm index 23377788a..755d6c8a0 100644 --- a/src/compiler/rtlopt/rtlcsm.scm +++ b/src/compiler/rtlopt/rtlcsm.scm @@ -97,8 +97,8 @@ USA. (add-pblock-to-classes! pblock-classes bblock))) (rgraph-bblocks rgraph)) (let ((singleton? (lambda (x) (null? (cdr x))))) - (append! (list-transform-negative (cdr sblock-classes) singleton?) - (list-transform-negative (cdr pblock-classes) singleton?))))) + (append! (remove singleton? (cdr sblock-classes)) + (remove singleton? (cdr pblock-classes)))))) (define (add-sblock-to-classes! classes sblock) (let ((next (snode-next sblock))) diff --git a/src/cref/conpkg.scm b/src/cref/conpkg.scm index 6557fc6c1..853f8f3bd 100644 --- a/src/cref/conpkg.scm +++ b/src/cref/conpkg.scm @@ -47,17 +47,17 @@ USA. (package-ancestryvector (map package-load->external - (list-transform-positive (pmodel/loads pmodel) - (lambda (load) - (or (pair? (package-load/file-cases load)) - (pair? (package-load/initializations load)) - (pair? (package-load/finalizations load))))))))) + (filter (lambda (load) + (or (pair? (package-load/file-cases load)) + (pair? (package-load/initializations load)) + (pair? (package-load/finalizations load)))) + (pmodel/loads pmodel)))))) (define (new-extension-packages pmodel) - (list-transform-positive (pmodel/extra-packages pmodel) - (lambda (package) - (or (any link/new? (package/links package)) - (any new-internal-binding? (package/bindings package)))))) + (filter (lambda (package) + (or (any link/new? (package/links package)) + (any new-internal-binding? (package/bindings package)))) + (pmodel/extra-packages pmodel))) (define (new-internal-binding? binding) (and (binding/new? binding) @@ -93,8 +93,8 @@ USA. '()))) (list->vector (map binding/name - (list-transform-positive (package/bindings package) - new-internal-binding?))) + (filter new-internal-binding? + (package/bindings package)))) (list->vector (map (lambda (link) (let ((source (link/source link)) diff --git a/src/cref/forpkg.scm b/src/cref/forpkg.scm index b0dd5065f..fda8a028f 100644 --- a/src/cref/forpkg.scm +++ b/src/cref/forpkg.scm @@ -51,9 +51,8 @@ USA. (output? #f)) (let ((free-references (append-map! (lambda (package) - (delete-matching-items - (package/references package) - reference/binding)) + (remove reference/binding + (package/references package))) packages))) (if (pair? free-references) (begin @@ -139,14 +138,14 @@ USA. (define (get-value-cells/unusual packages) (receive (unlinked linked) (get-value-cells packages) - (values (delete-matching-items linked - (lambda (value-cell) - (pair? (value-cell/expressions value-cell)))) - (keep-matching-items (append unlinked linked) - (lambda (value-cell) - (let ((expressions (value-cell/expressions value-cell))) - (and (pair? expressions) - (pair? (cdr expressions))))))))) + (values (remove (lambda (value-cell) + (pair? (value-cell/expressions value-cell))) + linked) + (filter (lambda (value-cell) + (let ((expressions (value-cell/expressions value-cell))) + (and (pair? expressions) + (pair? (cdr expressions))))) + (append unlinked linked))))) (define (get-value-cells packages) (let ((unlinked '()) diff --git a/src/edwin/autosv.scm b/src/edwin/autosv.scm index 1590a3876..ed6e56acb 100644 --- a/src/edwin/autosv.scm +++ b/src/edwin/autosv.scm @@ -147,12 +147,12 @@ This file is not the file you visited; that changes only when you save." (define (do-auto-save) (let ((buffers - (list-transform-positive (buffer-list) - (lambda (buffer) - (and (buffer-auto-save-pathname buffer) - (buffer-auto-save-modified? buffer) - (<= (* 10 (buffer-save-length buffer)) - (* 13 (buffer-length buffer)))))))) + (filter (lambda (buffer) + (and (buffer-auto-save-pathname buffer) + (buffer-auto-save-modified? buffer) + (<= (* 10 (buffer-save-length buffer)) + (* 13 (buffer-length buffer))))) + (buffer-list)))) (if (not (null? buffers)) (begin (temporary-message "Auto saving...") diff --git a/src/edwin/comtab.scm b/src/edwin/comtab.scm index 66b1fd962..bc467480a 100644 --- a/src/edwin/comtab.scm +++ b/src/edwin/comtab.scm @@ -67,17 +67,18 @@ USA. (set-comtab-alist! comtab alist))) (let* ((vector (make-vector 256 false)) (alist - (list-transform-negative alist - (lambda (entry) - (let ((key (car entry))) - (and (char? key) - (< (char->integer key) 256) - (begin - (vector-set! - vector - (char->integer key) - (cdr entry)) - true))))))) + (remove (lambda (entry) + (let ((key (car entry))) + (and (char? key) + (< (char->integer key) + 256) + (begin + (vector-set! + vector + (char->integer key) + (cdr entry)) + true)))) + alist))) (without-interrupts (lambda () (set-comtab-vector! comtab vector) diff --git a/src/edwin/debug.scm b/src/edwin/debug.scm index 30cc5d47e..1772b847f 100644 --- a/src/edwin/debug.scm +++ b/src/edwin/debug.scm @@ -700,7 +700,8 @@ USA. (max summary-minimum-columns (- columns indentation 4)) (lambda (port) - (parameterize* (list (cons current-output-port port)) + (parameterize* + (list (cons current-output-port port)) (lambda () ((bline-type/write-summary (bline/type bline)) @@ -1060,10 +1061,10 @@ The buffer below shows the current subproblem or reduction. buffer))) (define (find-debugger-buffers) - (list-transform-positive (buffer-list) - (let ((debugger-mode (ref-mode-object continuation-browser))) - (lambda (buffer) - (eq? (buffer-major-mode buffer) debugger-mode))))) + (filter (let ((debugger-mode (ref-mode-object continuation-browser))) + (lambda (buffer) + (eq? (buffer-major-mode buffer) debugger-mode))) + (buffer-list))) ;;;; Continuation Browser Mode diff --git a/src/edwin/display.scm b/src/edwin/display.scm index 4ebfe1db7..d3d95ca1a 100644 --- a/src/edwin/display.scm +++ b/src/edwin/display.scm @@ -86,7 +86,7 @@ USA. ((display-type/operation/with-interrupts-disabled display-type) thunk)) (define (editor-display-types) - (list-transform-positive display-types display-type/available?)) + (filter display-type/available? display-types)) (define (name->display-type name) (let ((display-type diff --git a/src/edwin/dos.scm b/src/edwin/dos.scm index 9d6f5fa20..67952bcc3 100644 --- a/src/edwin/dos.scm +++ b/src/edwin/dos.scm @@ -68,12 +68,13 @@ USA. (let ((entries (directory-read file #f #t))) (if all-files? entries - (list-transform-positive entries - (let ((mask - (fix:or nt-file-mode/hidden nt-file-mode/system))) - (lambda (entry) - (fix:= (fix:and (file-attributes/modes (cdr entry)) mask) - 0)))))))) + (filter (let ((mask + (fix:or nt-file-mode/hidden nt-file-mode/system))) + (lambda (entry) + (fix:= (fix:and (file-attributes/modes (cdr entry)) + mask) + 0))) + entries))))) ;;;; Win32 Clipboard Interface diff --git a/src/edwin/filcom.scm b/src/edwin/filcom.scm index 33b275565..c385f85e6 100644 --- a/src/edwin/filcom.scm +++ b/src/edwin/filcom.scm @@ -439,13 +439,13 @@ With argument, saves all with no questions." (define (save-some-buffers no-confirmation? exiting?) (let ((buffers (let ((exiting? (and (not (default-object? exiting?)) exiting?))) - (list-transform-positive (buffer-list) - (lambda (buffer) - (and (buffer-modified? buffer) - (or (buffer-pathname buffer) - (and exiting? - (ref-variable buffer-offer-save buffer) - (> (buffer-length buffer) 0))))))))) + (filter (lambda (buffer) + (and (buffer-modified? buffer) + (or (buffer-pathname buffer) + (and exiting? + (ref-variable buffer-offer-save buffer) + (> (buffer-length buffer) 0))))) + (buffer-list))))) (for-each (if (and (not (default-object? no-confirmation?)) no-confirmation?) (lambda (buffer) @@ -852,19 +852,19 @@ Prefix arg means treat the plaintext file as binary data." (lambda () (canonicalize-filename-completions directory - (list-transform-positive filenames - (lambda (filename) - (string-prefix? string filename)))))))))) + (filter (lambda (filename) + (string-prefix? string filename)) + filenames)))))))) (cond ((null? filenames) (if-not-found)) ((null? (cdr filenames)) (unique-case (car filenames))) (else (let ((filtered-filenames - (list-transform-negative filenames - (lambda (filename) - (completion-ignore-filename? - (merge-pathnames filename directory)))))) + (remove (lambda (filename) + (completion-ignore-filename? + (merge-pathnames filename directory))) + filenames))) (cond ((null? filtered-filenames) (non-unique-case filenames filenames)) ((null? (cdr filtered-filenames)) diff --git a/src/edwin/keymap.scm b/src/edwin/keymap.scm index fff6d7993..793fa8aac 100644 --- a/src/edwin/keymap.scm +++ b/src/edwin/keymap.scm @@ -152,9 +152,9 @@ Previous contents of that buffer are killed first." (map (lambda (element) (cons (xkey->name (car element)) (command-name-string (cdr element)))) - (sort (list-transform-negative elements - (lambda (element) - (button? (car element)))) + (sort (remove (lambda (element) + (button? (car element))) + elements) (lambda (a b) (xkeykey numbers) - (lambda (key) - (gdbm-exists? gdbf key))))) + (remove (lambda (key) + (gdbm-exists? gdbf key)) + (map ->key numbers)))) (if (not (null? keys)) (read-headers group keys #t '() (lambda (key reply replies) @@ -1084,13 +1084,13 @@ USA. (prune-header-alist alist))))) (define (prune-header-alist alist) - (list-transform-positive alist - (lambda (entry) - (or (string-ci=? (car entry) "subject") - (string-ci=? (car entry) "references") - (string-ci=? (car entry) "from") - (string-ci=? (car entry) "lines") - (string-ci=? (car entry) "xref"))))) + (filter (lambda (entry) + (or (string-ci=? (car entry) "subject") + (string-ci=? (car entry) "references") + (string-ci=? (car entry) "from") + (string-ci=? (car entry) "lines") + (string-ci=? (car entry) "xref"))) + alist)) (define (header-text-parser name) (let ((key (string-append name ":"))) @@ -1485,13 +1485,13 @@ USA. (define (compute-redundant-relatives step table header) (let ((relatives (step header))) - (list-transform-positive relatives - (lambda (child) - (any (lambda (child*) - (and (not (eq? child* child)) - (memq child - (compute-header-relatives step table child*)))) - relatives))))) + (filter (lambda (child) + (any (lambda (child*) + (and (not (eq? child* child)) + (memq child + (compute-header-relatives step table child*)))) + relatives)) + relatives))) (define (compute-header-relatives step table header) (let loop ((header header)) @@ -1561,9 +1561,9 @@ USA. (define (discard-useless-dummy-headers dummy-headers) (for-each maybe-discard-dummy-header dummy-headers) - (list-transform-negative dummy-headers - (lambda (header) - (null? (news-header:followups header))))) + (remove (lambda (header) + (null? (news-header:followups header))) + dummy-headers)) (define (maybe-discard-dummy-header header) (let ((children (news-header:followups header))) diff --git a/src/edwin/prompt.scm b/src/edwin/prompt.scm index 0fe52a720..96fcb5ca7 100644 --- a/src/edwin/prompt.scm +++ b/src/edwin/prompt.scm @@ -730,15 +730,16 @@ a repetition of this command will exit." (let ((try-suffix (lambda (suffix if-not-found) (let ((completions - (list-transform-positive completions - (let ((prefix (string-append string suffix))) - (if (case-insensitive-completion?) - (lambda (completion) - (string-prefix-ci? prefix - completion)) - (lambda (completion) - (string-prefix? prefix - completion))))))) + (filter (let ((prefix + (string-append string suffix))) + (if (case-insensitive-completion?) + (lambda (completion) + (string-prefix-ci? prefix + completion)) + (lambda (completion) + (string-prefix? prefix + completion)))) + completions))) (cond ((null? completions) (if-not-found)) ((null? (cdr completions)) @@ -978,7 +979,8 @@ it is added to the front of the command history." (set-prompt-history-strings! 'REPEAT-COMPLEX-COMMAND (map (lambda (command) - (parameterize* (list (cons param:unparse-with-maximum-readability? #t)) + (parameterize* (list (cons param:unparse-with-maximum-readability? + #t)) (lambda () (write-to-string command)))) (command-history-list))) diff --git a/src/edwin/rfc822.scm b/src/edwin/rfc822.scm index c59194bdf..bdfdc92f1 100644 --- a/src/edwin/rfc822.scm +++ b/src/edwin/rfc822.scm @@ -373,10 +373,10 @@ USA. tokens)) (define (rfc822:strip-comments tokens) - (list-transform-negative tokens - (lambda (token) - (and (string? token) - (char=? #\( (string-ref token 0)))))) + (remove (lambda (token) + (and (string? token) + (char=? #\( (string-ref token 0)))) + tokens)) ;;;; Tokenizer diff --git a/src/edwin/snr.scm b/src/edwin/snr.scm index f36641b14..4b30027cf 100644 --- a/src/edwin/snr.scm +++ b/src/edwin/snr.scm @@ -2249,8 +2249,8 @@ This command has no effect if the variable (update-subsequent-news-header-lines (buffer-start buffer)) (buffer-put! buffer 'NEWS-THREADS (list->vector - (list-transform-negative threads - news-thread:all-articles-deleted?))) + (remove news-thread:all-articles-deleted? + threads))) (if (and on-header? (not (region-get (current-point) 'NEWS-HEADER #f))) (let ((ls @@ -2838,11 +2838,11 @@ While composing the reply, use \\[mail-yank-original] to yank the select-buffer-other-window))))) (define (merge-header-alists x y) - (append (list-transform-negative x - (lambda (entry) - (list-search-positive y - (lambda (entry*) - (string-ci=? (car entry) (car entry*)))))) + (append (remove (lambda (entry) + (find (lambda (entry*) + (string-ci=? (car entry) (car entry*))) + y)) + x) y)) (define (news-article-buffer:rfc822-reply-headers article-buffer) @@ -4154,8 +4154,8 @@ With prefix arg, replaces the file with the list information." (if (or (command-argument-multiplier-only? argument) (ref-variable news-group-show-seen-headers buffer)) threads - (list-transform-negative threads - news-thread:all-articles-deleted?)))))) + (remove news-thread:all-articles-deleted? + threads)))))) (define (news-group:get-headers group argument buffer) (let ((connection (news-group:connection group)) diff --git a/src/imail/imail-browser.scm b/src/imail/imail-browser.scm index c95e4f7d1..964d30b5b 100644 --- a/src/imail/imail-browser.scm +++ b/src/imail/imail-browser.scm @@ -197,10 +197,10 @@ USA. (find-browsers-for container))) (define (find-browsers-for container) - (list-transform-positive (buffer-list) - (lambda (buffer) - (or (eq? (selected-container #f buffer) container) - (memq container (browser-expanded-containers buffer)))))) + (filter (lambda (buffer) + (or (eq? (selected-container #f buffer) container) + (memq container (browser-expanded-containers buffer)))) + (buffer-list))) (define (browser-expanded-containers buffer) (buffer-get buffer 'IMAIL-BROWSER-EXPANDED-CONTAINERS '())) diff --git a/src/imail/imail-core.scm b/src/imail/imail-core.scm index f48523d12..fc7af2f92 100644 --- a/src/imail/imail-core.scm +++ b/src/imail/imail-core.scm @@ -1073,9 +1073,9 @@ USA. (else winner)))) (define (get-all-header-fields headers name) - (list-transform-positive (->header-fields headers) - (lambda (header) - (string-ci=? name (header-field-name header))))) + (filter (lambda (header) + (string-ci=? name (header-field-name header))) + (->header-fields headers))) (define (get-first-header-field-value headers name error?) (let ((header (get-first-header-field headers name error?))) diff --git a/src/imail/imail-imap.scm b/src/imail/imail-imap.scm index b4fed13a5..f3be5b242 100644 --- a/src/imail/imail-imap.scm +++ b/src/imail/imail-imap.scm @@ -1401,9 +1401,9 @@ USA. #t))))) (define (select-uncached-keywords message keywords) - (delete-matching-items keywords - (lambda (keyword) - (imap-message-keyword-cached? message keyword)))) + (remove (lambda (keyword) + (imap-message-keyword-cached? message keyword)) + keywords)) ;;;; MIME support @@ -1861,9 +1861,9 @@ USA. '()))))) keywords))) (let ((uncached - (list-transform-positive alist - (lambda (entry) - (null? (cdr entry)))))) + (filter (lambda (entry) + (null? (cdr entry))) + alist))) (if (pair? uncached) (let ((response (fetch-message-items-1 message diff --git a/src/imail/imail-top.scm b/src/imail/imail-top.scm index 739cc1632..8afbfeb62 100644 --- a/src/imail/imail-top.scm +++ b/src/imail/imail-top.scm @@ -1019,10 +1019,9 @@ With prefix argument, prompt even when point is on an attachment." (map (lambda (i.m) (cons (mime-attachment-name (car i.m) #t) i.m)) - (list-transform-positive - (buffer-mime-info (mark-buffer mark)) - (lambda (i.m) - (predicate (car i.m)))))))) + (filter (lambda (i.m) + (predicate (car i.m))) + (buffer-mime-info (mark-buffer mark))))))) (if (pair? alist) (if (or (pair? (cdr alist)) always-prompt?) (prompt-for-alist-value @@ -1269,9 +1268,9 @@ ADDRESSES is a string consisting of several addresses separated by commas." `(("Resent-Bcc" ,(mail-from-string buffer))) '()) ,@(map header-field->mail-header - (list-transform-negative (message-header-fields message) - (lambda (header) - (string-ci=? (header-field-name header) "sender"))))) + (remove (lambda (header) + (string-ci=? (header-field-name header) "sender")) + (message-header-fields message)))) #f (lambda (mail-buffer) (initialize-imail-mail-buffer mail-buffer) @@ -2295,11 +2294,12 @@ WARNING: With a prefix argument, this command may take a very long (let ((mime-headers (lambda () (if keep-mime? - (list-transform-positive headers - (lambda (header) - (re-string-match "^\\(mime-version$\\|content-\\)" - (header-field-name header) - #t))) + (filter (lambda (header) + (re-string-match + "^\\(mime-version$\\|content-\\)" + (header-field-name header) + #t)) + headers) '())))) (cond ((ref-variable imail-kept-headers context) => (lambda (regexps) @@ -2307,29 +2307,28 @@ WARNING: With a prefix argument, this command may take a very long (append-map*! (mime-headers) (lambda (regexp) - (list-transform-positive headers - (lambda (header) - (re-string-match regexp - (header-field-name header) - #t)))) + (filter (lambda (header) + (re-string-match regexp + (header-field-name header) + #t)) + headers)) regexps) (lambda (a b) (eq? a b))))) ((ref-variable imail-ignored-headers context) => (lambda (regexp) (remove-duplicates! (append! - (list-transform-negative headers - (lambda (header) - (re-string-match regexp - (header-field-name header) - #t))) + (remove (lambda (header) + (re-string-match regexp + (header-field-name header) + #t)) + headers) (mime-headers)) (lambda (a b) (eq? a b))))) (else headers)))) (filter (ref-variable imail-message-filter context))) (if filter - (map (lambda (n.v) - (make-header-field (car n.v) (cdr n.v))) + (map (lambda (n.v) (make-header-field (car n.v) (cdr n.v))) (filter (map (lambda (header) (cons (header-field-name header) (header-field-value header))) diff --git a/src/imail/imail-util.scm b/src/imail/imail-util.scm index f013ed1bb..6ffce1036 100644 --- a/src/imail/imail-util.scm +++ b/src/imail/imail-util.scm @@ -283,8 +283,8 @@ USA. (loop (+ j 1) (* k 10))))) (define (burst-comma-list-string string) - (list-transform-negative (map string-trim (burst-string string #\, #f)) - string-null?)) + (remove string-null? + (map string-trim (burst-string string #\, #f)))) (define (string-greatest-common-prefix strings) (let loop diff --git a/src/microcode/makegen/makegen.scm b/src/microcode/makegen/makegen.scm index c12246011..d3df3a3a7 100644 --- a/src/microcode/makegen/makegen.scm +++ b/src/microcode/makegen/makegen.scm @@ -40,10 +40,10 @@ USA. (map (lambda (pathname) (cons (pathname-name pathname) (read-file pathname))) - (keep-matching-items (directory-read "makegen/") - (lambda (pathname) - (re-string-match "^files-.+\\.scm$" - (file-namestring pathname))))))) + (filter (lambda (pathname) + (re-string-match "^files-.+\\.scm$" + (file-namestring pathname))) + (directory-read "makegen/"))))) (call-with-input-file "makegen/Makefile.in.in" (lambda (input) (call-with-output-file "Makefile.in" @@ -121,10 +121,10 @@ USA. (append-map (lambda (spec) (let ((dir (pathname-as-directory (car spec)))) (if (file-directory? dir) - (delete-matching-items - (directory-read (merge-pathnames "*.scm" dir)) - (lambda (path) - (member (pathname-name path) (cdr spec)))) + (remove (lambda (path) + (member (pathname-name path) (cdr spec))) + (directory-read + (merge-pathnames "*.scm" dir))) (begin (warn "Can't read directory:" dir) '())))) @@ -233,5 +233,5 @@ USA. (error "Missing rule target:" rule)) (cons* (string-head (car items) (- (string-length (car items)) 1)) (cadr items) - (sort (delete-matching-items (cddr items) pathname-absolute?) + (sort (remove pathname-absolute? (cddr items)) stringlist - (dbg-block/layout-vector (stack-ccenv/block environment))) - dbg-variable?))) + (filter dbg-variable? + (vector->list + (dbg-block/layout-vector (stack-ccenv/block environment)))))) (define (stack-ccenv/reference-type environment name) (dbg-variable-reference-type (stack-ccenv/block environment) @@ -738,16 +737,16 @@ USA. (define (closure-ccenv/bound-names environment) (map dbg-variable/name - (list-transform-positive - (vector->list - (dbg-block/layout-vector (closure-ccenv/stack-block environment))) - (lambda (variable) - (and (dbg-variable? variable) - (or (eq? (dbg-variable/type variable) 'integrated) - (vector-find-next-element - (dbg-block/layout-vector - (closure-ccenv/closure-block environment)) - variable))))))) + (filter (lambda (variable) + (and (dbg-variable? variable) + (or (eq? (dbg-variable/type variable) 'integrated) + (vector-find-next-element + (dbg-block/layout-vector + (closure-ccenv/closure-block environment)) + variable)))) + (vector->list + (dbg-block/layout-vector + (closure-ccenv/stack-block environment)))))) (define (closure-ccenv/reference-type environment name) (dbg-variable-reference-type (closure-ccenv/closure-block environment) diff --git a/src/runtime/graphics.scm b/src/runtime/graphics.scm index d1f244004..575359ea0 100644 --- a/src/runtime/graphics.scm +++ b/src/runtime/graphics.scm @@ -218,7 +218,7 @@ USA. (graphics-type type #f)) (define (enumerate-graphics-types) - (list-transform-positive graphics-types graphics-device-type/available?)) + (filter graphics-device-type/available? graphics-types)) (define (graphics-device-type/available? type) ((graphics-device-type/operation/available? type))) diff --git a/src/runtime/list.scm b/src/runtime/list.scm index fa1c3cfd5..096e69198 100644 --- a/src/runtime/list.scm +++ b/src/runtime/list.scm @@ -929,116 +929,30 @@ USA. #f)))) (define (count-matching-items items predicate) - (do ((items* items (cdr items*)) - (n 0 (if (predicate (car items*)) (fix:+ n 1) n))) - ((not (pair? items*)) - (if (not (null? items*)) - (error:not-a list? items 'count-matching-items)) - n))) + (count predicate items)) (define (count-non-matching-items items predicate) - (do ((items* items (cdr items*)) - (n 0 (if (predicate (car items*)) n (fix:+ n 1)))) - ((not (pair? items*)) - (if (not (null? items*)) - (error:not-a list? items 'count-non-matching-items)) - n))) + (count (lambda (item) + (not (predicate item))) + items)) (define (keep-matching-items items predicate) - (let ((lose (lambda () (error:not-a list? items 'keep-matching-items)))) - (cond ((pair? items) - (let ((head (cons (car items) '()))) - (let loop ((items* (cdr items)) (previous head)) - (cond ((pair? items*) - (if (predicate (car items*)) - (let ((new (cons (car items*) '()))) - (set-cdr! previous new) - (loop (cdr items*) new)) - (loop (cdr items*) previous))) - ((not (null? items*)) (lose)))) - (if (predicate (car items)) - head - (cdr head)))) - ((null? items) items) - (else (lose))))) + (filter predicate items)) (define (delete-matching-items items predicate) - (let ((lose (lambda () (error:not-a list? items 'delete-matching-items)))) - (cond ((pair? items) - (let ((head (cons (car items) '()))) - (let loop ((items* (cdr items)) (previous head)) - (cond ((pair? items*) - (if (predicate (car items*)) - (loop (cdr items*) previous) - (let ((new (cons (car items*) '()))) - (set-cdr! previous new) - (loop (cdr items*) new)))) - ((not (null? items*)) (lose)))) - (if (predicate (car items)) - (cdr head) - head))) - ((null? items) items) - (else (lose))))) - + (remove predicate items)) + (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:not-a list? items 'delete-matching-items!)))) - (trim-initial-segment items))) + (remove! predicate 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:not-a list? items 'keep-matching-items!)))) - (trim-initial-segment items))) + (filter! predicate items)) (define ((list-deletor predicate) items) - (delete-matching-items items predicate)) + (remove predicate items)) (define ((list-deletor! predicate) items) - (delete-matching-items! items predicate)) + (remove! predicate items)) ;;;; Membership lists diff --git a/src/runtime/regexp.scm b/src/runtime/regexp.scm index c589ee459..d538f2d90 100644 --- a/src/runtime/regexp.scm +++ b/src/runtime/regexp.scm @@ -125,7 +125,7 @@ USA. (define (regexp-group . alternatives) (let ((alternatives - (list-transform-positive alternatives identity-procedure))) + (filter identity-procedure alternatives))) (if (null? alternatives) "\\(\\)" (apply string-append diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm index dc020d393..63f2da82a 100644 --- a/src/runtime/rep.scm +++ b/src/runtime/rep.scm @@ -653,7 +653,7 @@ USA. (if (pair? restarts) (let ((rest (if (cmdl-abort-restart? (car restarts)) - (list-transform-positive (cdr restarts) cmdl-abort-restart?) + (filter cmdl-abort-restart? (cdr restarts)) (loop (cdr restarts))))) (if (restart/interactor (car restarts)) (cons (car restarts) rest) diff --git a/src/runtime/srfi-1.scm b/src/runtime/srfi-1.scm index 9d2ea0ce5..c07a7d4d4 100644 --- a/src/runtime/srfi-1.scm +++ b/src/runtime/srfi-1.scm @@ -372,7 +372,12 @@ USA. (if (apply pred (car list1) as) (fix:+ i 1) i)))))) - (count-matching-items list1 pred))) + (do ((items list1 (cdr items)) + (n 0 (if (pred (car items)) (fix:+ n 1) n))) + ((not (pair? items)) + (if (not (null? items)) + (error:not-a list? list1 'count)) + n)))) (define (zip list1 . more-lists) (apply map list list1 more-lists)) @@ -548,22 +553,11 @@ USA. ;;; FILTER, REMOVE, PARTITION and their destructive counterparts do not ;;; disorder the elements of their argument. -;; This FILTER shares the longest tail of L that has no deleted elements. -;; If Scheme had multi-continuation calls, they could be made more efficient. - -;; Sleazing with EQ? makes this one faster. - (define (filter pred lis) (let recur ((lis lis)) - (if (null-list? lis 'filter) - lis - (let ((head (car lis)) - (tail (cdr lis))) - (if (pred head) - (let ((new-tail (recur tail))) ; Replicate the RECUR call so - (if (eq? tail new-tail) lis - (cons head new-tail))) - (recur tail)))))) ; this one can be a tail call. + (cond ((null-list? lis 'filter) lis) + ((pred (car lis)) (cons (car lis) (recur (cdr lis)))) + (else (recur (cdr lis)))))) ;;; This implementation of FILTER! ;;; - doesn't cons, and uses no stack; diff --git a/src/runtime/stack-sample.scm b/src/runtime/stack-sample.scm index 64b792363..73f497521 100644 --- a/src/runtime/stack-sample.scm +++ b/src/runtime/stack-sample.scm @@ -289,8 +289,8 @@ (define (display-profile profile output-port) (let ((entries (hash-table/datum-list (profile.entries profile)))) (define (sortem entry.count) - (sort (delete-matching-items entries - (lambda (e) (zero? (entry.count e)))) + (sort (remove (lambda (e) (zero? (entry.count e))) + entries) (lambda (a b) (< (entry.count a) (entry.count b))))) (let ((sampled (sortem entry.sampled-count)) (waiting (sortem entry.waiting-count))) diff --git a/src/runtime/textual-port.scm b/src/runtime/textual-port.scm index a539f63f7..80589a171 100644 --- a/src/runtime/textual-port.scm +++ b/src/runtime/textual-port.scm @@ -157,18 +157,18 @@ USA. (parse-operations-list-1 (if parent-type (append operations - (delete-matching-items (textual-port-type-operations parent-type) - (let ((excluded - (append - (if (assq 'READ-CHAR operations) - standard-input-operation-names - '()) - (if (assq 'WRITE-CHAR operations) - standard-output-operation-names - '())))) - (lambda (p) - (or (assq (car p) operations) - (memq (car p) excluded)))))) + (remove (let ((excluded + (append + (if (assq 'READ-CHAR operations) + standard-input-operation-names + '()) + (if (assq 'WRITE-CHAR operations) + standard-output-operation-names + '())))) + (lambda (p) + (or (assq (car p) operations) + (memq (car p) excluded)))) + (textual-port-type-operations parent-type))) operations))) (define (parse-operations-list-1 operations) diff --git a/src/runtime/unxdir.scm b/src/runtime/unxdir.scm index 3ce14b6ef..c14ef0383 100644 --- a/src/runtime/unxdir.scm +++ b/src/runtime/unxdir.scm @@ -63,12 +63,12 @@ USA. (if (and (eq? (pathname-name pattern) 'wild) (eq? (pathname-type pattern) 'wild)) pathnames - (list-transform-positive pathnames - (lambda (instance) - (and (match-component (pathname-name pattern) - (pathname-name instance)) - (match-component (pathname-type pattern) - (pathname-type instance))))))))))) + (filter (lambda (instance) + (and (match-component (pathname-name pattern) + (pathname-name instance)) + (match-component (pathname-type pattern) + (pathname-type instance)))) + pathnames))))))) (define (generate-directory-pathnames pathname) (let ((channel (directory-channel-open (->namestring pathname)))) diff --git a/src/runtime/xeval.scm b/src/runtime/xeval.scm index 9c6f3113c..4d2fdf597 100644 --- a/src/runtime/xeval.scm +++ b/src/runtime/xeval.scm @@ -70,9 +70,9 @@ USA. (make-root-top-level-environment)))))))) (define (difference items items*) - (list-transform-negative items - (lambda (item) - (memq item items*)))) + (remove (lambda (item) + (memq item items*)) + items)) (define (environment-that-binds environment name) (let loop ((environment environment)) @@ -169,12 +169,13 @@ USA. (scode-access-name expression))) (define (rewrite/combination expression environment bound-names) - (make-scode-combination (rewrite/expression (scode-combination-operator expression) - environment - bound-names) - (rewrite/expressions (scode-combination-operands expression) - environment - bound-names))) + (make-scode-combination + (rewrite/expression (scode-combination-operator expression) + environment + bound-names) + (rewrite/expressions (scode-combination-operands expression) + environment + bound-names))) (define (rewrite/comment expression environment bound-names) (make-scode-comment (scode-comment-text expression) @@ -183,15 +184,16 @@ USA. bound-names))) (define (rewrite/conditional expression environment bound-names) - (make-scode-conditional (rewrite/expression (scode-conditional-predicate expression) - environment - bound-names) - (rewrite/expression (scode-conditional-consequent expression) - environment - bound-names) - (rewrite/expression (scode-conditional-alternative expression) - environment - bound-names))) + (make-scode-conditional + (rewrite/expression (scode-conditional-predicate expression) + environment + bound-names) + (rewrite/expression (scode-conditional-consequent expression) + environment + bound-names) + (rewrite/expression (scode-conditional-alternative expression) + environment + bound-names))) (define (rewrite/delay expression environment bound-names) (make-scode-delay (rewrite/expression (scode-delay-expression expression) @@ -199,12 +201,13 @@ USA. bound-names))) (define (rewrite/disjunction expression environment bound-names) - (make-scode-disjunction (rewrite/expression (scode-disjunction-predicate expression) - environment - bound-names) - (rewrite/expression (scode-disjunction-alternative expression) - environment - bound-names))) + (make-scode-disjunction + (rewrite/expression (scode-disjunction-predicate expression) + environment + bound-names) + (rewrite/expression (scode-disjunction-alternative expression) + environment + bound-names))) (define (rewrite/sequence expression environment bound-names) (make-scode-sequence (rewrite/expressions (scode-sequence-actions expression) diff --git a/src/sos/instance.scm b/src/sos/instance.scm index 583d7d202..47c341ddb 100644 --- a/src/sos/instance.scm +++ b/src/sos/instance.scm @@ -306,15 +306,15 @@ USA. (define (make-initialization class arg-slots) (let ((if-slots - (list-transform-positive (class-slots class) - (lambda (slot) - (and (slot-initializer slot) - (not (memq slot arg-slots)))))) + (filter (lambda (slot) + (and (slot-initializer slot) + (not (memq slot arg-slots)))) + (class-slots class))) (iv-slots - (list-transform-positive (class-slots class) - (lambda (slot) - (and (slot-initial-value? slot) - (not (memq slot arg-slots))))))) + (filter (lambda (slot) + (and (slot-initial-value? slot) + (not (memq slot arg-slots)))) + (class-slots class)))) (let ((if-n (length if-slots)) (iv-n (length iv-slots)) (if-indexes (map slot-index if-slots)) diff --git a/src/sos/method.scm b/src/sos/method.scm index a06775e2d..0a4a25bdb 100644 --- a/src/sos/method.scm +++ b/src/sos/method.scm @@ -165,13 +165,12 @@ USA. (define (try-computed-emps generic classes methods) (let loop ((generators - (sort-methods (list-transform-positive - (append-map enumerate-union-specializers - (list-transform-positive - (generic-procedure-methods generic) - computed-emp?)) - (lambda (method) - (method-applicable? method classes))) + (sort-methods (filter (lambda (method) + (method-applicable? method classes)) + (append-map enumerate-union-specializers + (filter computed-emp? + (generic-procedure-methods + generic)))) classes))) (and (not (null? generators)) (let ((result (apply (method-procedure (car generators)) classes))) @@ -196,11 +195,11 @@ USA. (define (compute-methods-1 generic classes) (let ((methods - (list-transform-positive (generic-procedure-methods generic) - (lambda (method) - (and (not (computed-emp? method)) - (method-applicable? method classes)))))) - (let ((results (list-transform-negative methods computed-method?))) + (filter (lambda (method) + (and (not (computed-emp? method)) + (method-applicable? method classes))) + (generic-procedure-methods generic)))) + (let ((results (remove computed-method? methods))) (for-each (lambda (method) (let ((result (apply (method-procedure method) classes))) @@ -224,7 +223,7 @@ USA. result method))) results)) unspecific)))) - (list-transform-positive methods computed-method?)) + (filter computed-method? methods)) results))) (define (method-applicable? method classes) diff --git a/src/star-parser/shared.scm b/src/star-parser/shared.scm index 333503cb8..dc3f384ea 100644 --- a/src/star-parser/shared.scm +++ b/src/star-parser/shared.scm @@ -437,9 +437,9 @@ USA. ((LAMBDA) `(LAMBDA ,(cadr expression) ,(loop (caddr expression) - (delete-matching-items substitutions - (lambda (s) - (memq (car s) (cadr expression))))))) + (remove (lambda (s) + (memq (car s) (cadr expression))) + substitutions)))) ((LET) `(LET ,(cadr expression) ,(map (lambda (binding) @@ -447,10 +447,10 @@ USA. ,(loop (cadr binding) substitutions))) (caddr expression)) ,(loop (cadddr expression) - (delete-matching-items substitutions - (lambda (s) - (or (eq? (car s) (cadr expression)) - (assq (car s) (caddr expression)))))))) + (remove (lambda (s) + (or (eq? (car s) (cadr expression)) + (assq (car s) (caddr expression)))) + substitutions)))) ((PROTECT) expression) (else @@ -637,18 +637,18 @@ USA. (case (car expression) ((LAMBDA) (loop (caddr expression) - (delete-matching-items alist - (lambda (entry) - (memq (car entry) (cadr expression)))))) + (remove (lambda (entry) + (memq (car entry) (cadr expression))) + alist))) ((LET) (for-each (lambda (binding) (loop (cadr binding) alist)) (caddr expression)) (loop (cadddr expression) - (delete-matching-items alist - (lambda (entry) - (or (eq? (car entry) (cadr expression)) - (assq (car entry) (caddr expression))))))) + (remove (lambda (entry) + (or (eq? (car entry) (cadr expression)) + (assq (car entry) (caddr expression)))) + alist))) ((PROTECT) unspecific) (else @@ -772,9 +772,9 @@ USA. (define (%drop-pointer-refs identifiers pointers) (cons #f (map (lambda (ids) - (delete-matching-items ids - (lambda (id) - (memq id identifiers)))) + (remove (lambda (id) + (memq id identifiers)) + ids)) (cdr pointers)))) (define (%current-pointers pointers) diff --git a/src/xdoc/xdoc.scm b/src/xdoc/xdoc.scm index 7a7c21b2a..58be6d823 100644 --- a/src/xdoc/xdoc.scm +++ b/src/xdoc/xdoc.scm @@ -123,10 +123,10 @@ USA. (let ((strip! (lambda (object accessor modifier) (modifier object - (delete-matching-items! (accessor object) xml-comment?)) + (remove! xml-comment? (accessor object))) (modifier object - (delete-matching-items! (accessor object) - xml-whitespace-string?))))) + (remove! xml-whitespace-string? + (accessor object)))))) (strip! document xml-document-misc-1 set-xml-document-misc-1!) (set-xml-document-dtd! document #f) (strip! document xml-document-misc-2 set-xml-document-misc-2!) @@ -497,10 +497,10 @@ USA. (http-request-url))) (generate-container-items (if (confirming-submission? elt) - (keep-matching-items (xml-element-contents elt) - (lambda (item) - (or (xd:page-frame? item) - (xd:when? item)))) + (filter (lambda (item) + (or (xd:page-frame? item) + (xd:when? item))) + (xml-element-contents elt)) (xml-element-contents elt)) (lambda (elt) (or (xd:head? elt) @@ -1270,12 +1270,12 @@ USA. (preserved-attributes elt))) (define (preserved-attributes elt) - (keep-matching-items (xml-element-attributes elt) preserved-attribute?)) + (filter preserved-attribute? (xml-element-attributes elt))) (define (merge-attributes attrs defaults) - (map* (delete-matching-items defaults - (lambda (attr) - (%find-attribute (xml-attribute-name attr) attrs))) + (map* (remove (lambda (attr) + (%find-attribute (xml-attribute-name attr) attrs)) + defaults) (lambda (attr) (let ((attr* (and (merged-attribute? attr) diff --git a/src/xml/xpath.scm b/src/xml/xpath.scm index e8276956a..7b994c2a7 100644 --- a/src/xml/xpath.scm +++ b/src/xml/xpath.scm @@ -139,10 +139,10 @@ USA. (lambda (item) (or (xml-comment? item) (xml-processing-instructions? item))))) - (append! (keep-matching-items (xml-document-misc-1 doc) p) - (keep-matching-items (xml-document-misc-2 doc) p) + (append! (filter p (xml-document-misc-1 doc)) + (filter p (xml-document-misc-2 doc)) (list (xml-document-root doc)) - (keep-matching-items (xml-document-misc-3 doc) p))) + (filter p (xml-document-misc-3 doc)))) node) node)))) -- 2.25.1