(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
(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."
(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
(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*))
(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)))
;; 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)
(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)))
\f
(define (map->weighted-entries register-map weight)
(map (lambda (entry)
(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)
(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)))
(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))
(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)
(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
(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)))))))
(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))))
(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)
(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)))
(examine-children block update?))
(else
(error "Illegal block type" block))))
-
+
(define (examine-children block update?)
(for-each (lambda (child)
(loop child update?))
(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))))
\f
(define (maybe-close-procedure! procedure)
(if (eq? true (procedure-closure-context procedure))
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!
\f
(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
;;; is difficult to determine how to make it work well.
\f
(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)
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?
;; 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)
(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)
(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)
#|
(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))
|#
(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))
\f
#|
(define (fold-combinations combinations)
(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
(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))))
\f
(define (complex-parallel-constraints subproblems vars-referenced-later)
(with-values (lambda () (discriminate-items subproblems subproblem-simple?))
(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
;;; 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)
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)))
(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))
(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))
(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)
(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))
(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)))))))
\f
(define-export (clear-call-graph! procedures)
;; 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!
(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)
(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)))
(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
(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)
((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)
(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)))
(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)
((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)
(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)
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))
(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))
(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)
(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)
(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)
((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)
(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)
((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)
(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
(define-expression-method 'ADDRESS
(address-method
(lambda (receiver scfg-append!)
- scfg-append! ;ignore
+ (declare (ignore scfg-append!))
(lambda (address offset granularity)
(receiver
(case granularity
(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))))
(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
(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
(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
(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))
(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)))
(set-register-value! register false)))))
\f
(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
(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)))
(package-ancestry<? (car a) (car b))))))
(list->vector
(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)
'())))
(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))
(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
(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 '())
(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...")
(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)
(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))
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)))
\f
;;;; Continuation Browser Mode
((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
(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)))))
\f
;;;; Win32 Clipboard Interface
(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)
(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))
(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) (xkey<? (car a) (car b))))))
(define (sort-by-prefix elements)
(let ((gdbf (news-group:header-gdbf group #t)))
(if gdbf
(let ((keys
- (list-transform-negative (map ->key 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)
(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))
\f
(define (header-text-parser name)
(let ((key (string-append name ":")))
\f
(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))
(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)))
(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))
(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)))
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))
\f
;;;; Tokenizer
(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
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)
(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))
(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 '()))
(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?)))
#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))
\f
;;;; MIME support
'())))))
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
(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
`(("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)
(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)
(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)))
(loop (+ j 1) (* k 10)))))
\f
(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
(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"
(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)
'()))))
(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))
string<?))))
\ No newline at end of file
(eq? (option/keyword option) keyword))))
(define (find-options keyword options)
- (keep-matching-items options
- (lambda (option)
- (eq? (option/keyword option) keyword))))
+ (filter (lambda (option)
+ (eq? (option/keyword option) keyword))
+ options))
(define (check-for-duplicate-constructors constructor-options
keyword-constructor-options)
(,(absolute 'list-tail context) structure
,(slot/index slot))
value)))))))
- (delete-matching-items (structure/slots structure) slot/read-only?))))
+ (remove slot/read-only? (structure/slots structure)))))
\f
(define (constructor-definitions structure)
`(,@(map (lambda (constructor)
(define (stack-ccenv/bound-names environment)
(map dbg-variable/name
- (list-transform-positive
- (vector->list
- (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)
(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)
(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)))
#f))))
\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)))))
-\f
+ (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))
\f
;;;; Membership lists
(define (regexp-group . alternatives)
(let ((alternatives
- (list-transform-positive alternatives identity-procedure)))
+ (filter identity-procedure alternatives)))
(if (null? alternatives)
"\\(\\)"
(apply string-append
(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)
(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))))
\f
(define (zip list1 . more-lists)
(apply map list list1 more-lists))
;;; 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;
(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)))
(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)
(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))))
(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))
(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)))
\f
(define (rewrite/comment expression environment bound-names)
(make-scode-comment (scode-comment-text expression)
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)
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)
\f
(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))
(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)))
(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)))
result method)))
results))
unspecific))))
- (list-transform-positive methods computed-method?))
+ (filter computed-method? methods))
results)))
(define (method-applicable? method classes)
((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)
,(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
(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
(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)
(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!)
(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)
(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)
(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))))
projects / mit-scheme.git / commitdiff