diff --git a/lib/chibi/optimize/rest.scm b/lib/chibi/optimize/rest.scm index 90df782d..d9be556b 100644 --- a/lib/chibi/optimize/rest.scm +++ b/lib/chibi/optimize/rest.scm @@ -19,17 +19,17 @@ (lambda (p a) (match a (((? (lambda (op) (eq? op cdr))) ($ Ref name (_ . (? lambda? lam)))) - (let ((x (any (lambda (r) - (and (eq? name (car r)) (eq? lam (cadr r)))) - cdrs))) + (let ((x (find (lambda (r) + (and (eq? name (car r)) (eq? lam (cadr r)))) + cdrs))) (and x (list p f (+ (caddr x) 1))))) (($ Cnd ((? (lambda (op) (eq? op pair?))) ($ Ref name (_ . (? lambda? lam)))) ((? (lambda (op) (eq? op cdr))) ($ Ref name (_ . (? lambda? lam)))) (or () ($ Lit ()))) - (let ((x (any (lambda (r) - (and (eq? name (car r)) (eq? lam (cadr r)))) - cdrs))) + (let ((x (find (lambda (r) + (and (eq? name (car r)) (eq? lam (cadr r)))) + cdrs))) (and x (list p f (+ (caddr x) 1.0))))) (else #f))) params @@ -80,8 +80,8 @@ (and ls (make-seq ls)))) (((? opcode? op) ($ Ref name (_ . (? lambda? f)))) (let ((r (and (memq op safe-primitives) - (any (lambda (r) (and (eq? name (car r)) (eq? f (cadr r)))) - cdrs)))) + (find (lambda (r) (and (eq? name (car r)) (eq? f (cadr r)))) + cdrs)))) (cond ((not r) x) diff --git a/lib/init.scm b/lib/init.scm index 8e37d1df..fe78fdf9 100644 --- a/lib/init.scm +++ b/lib/init.scm @@ -91,26 +91,25 @@ (define (any pred ls . lol) (define (any1 pred ls) - (if (pair? ls) (if (pred (car ls)) (car ls) (any1 pred (cdr ls))) #f)) + (if (null? (cdr ls)) + (pred (car ls)) + ((lambda (x) (if x x (any1 pred (cdr ls)))) (pred (car ls))))) (define (anyn pred lol) (if (every pair? lol) - ((lambda (args) (if (apply pred args) args (anyn pred (map cdr lol)))) - (map car lol)) + ((lambda (x) (if x x (anyn pred (map cdr lol)))) + (apply pred (map car lol))) #f)) - (if (null? lol) (any1 pred ls) (anyn pred (cons ls lol)))) + (if (null? lol) (if (null? ls) #f (any1 pred ls)) (anyn pred (cons ls lol)))) (define (every pred ls . lol) (define (every1 pred ls) - (if (pair? ls) (if (pred (car ls)) (every1 pred (cdr ls)) #f) #t)) + (if (null? (cdr ls)) + (pred (car ls)) + (if (pred (car ls)) (every1 pred (cdr ls)) #f))) (if (null? lol) - (every1 pred ls) + (if (null? ls) #t (every1 pred ls)) (not (apply any (lambda (x) (not (pred x))) ls lol)))) -(define (delq x ls) - (if (pair? ls) - (if (eq? x (car ls)) (delq x (cdr ls)) (cons (car ls) (delq x (cdr ls)))) - '())) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; syntax @@ -408,6 +407,12 @@ (define assv assoc) +(define (find-tail pred ls) + (and (pair? ls) (if (pred (car ls)) ls (find-tail pred (cdr ls))))) + +(define (find pred ls) + (cond ((find-tail pred ls) => car) (else #f))) + ;; math utils (define (number? x) (if (fixnum? x) #t (if (bignum? x) #t (flonum? x)))) @@ -771,7 +776,7 @@ (cond ((identifier? t) (cond - ((any (lambda (v) (compare t (car v))) vars) + ((find (lambda (v) (compare t (car v))) vars) => (lambda (cell) (if (<= (cdr cell) dim) t diff --git a/lib/srfi/1/search.scm b/lib/srfi/1/search.scm index 3b6f2443..9b65b1ca 100644 --- a/lib/srfi/1/search.scm +++ b/lib/srfi/1/search.scm @@ -2,12 +2,6 @@ ;; Copyright (c) 2009-2011 Alex Shinn. All rights reserved. ;; BSD-style license: http://synthcode.com/license.txt -(define (find pred ls) - (cond ((find-tail pred ls) => car) (else #f))) - -(define (find-tail pred ls) - (and (pair? ls) (if (pred (car ls)) ls (find-tail pred (cdr ls))))) - (define (take-while pred ls) (let lp ((ls ls) (res '())) (if (and (pair? ls) (pred (car ls))) diff --git a/tools/chibi-doc b/tools/chibi-doc index 2706ad26..1ec09637 100755 --- a/tools/chibi-doc +++ b/tools/chibi-doc @@ -406,7 +406,7 @@ div#footer {padding-bottom: 50px} (define (section>=? x n) (and (pair? x) (if (memq (car x) '(div)) - (any (lambda (y) (section>=? y n)) (sxml-body x)) + (find (lambda (y) (section>=? y n)) (sxml-body x)) (>= (section-number (car x)) n)))) (define (extract-sxml tag x) diff --git a/tools/chibi-ffi b/tools/chibi-ffi index 3c8fe065..43a62525 100755 --- a/tools/chibi-ffi +++ b/tools/chibi-ffi @@ -744,11 +744,11 @@ ((and (not (type-default? arg)) (type-value arg)) => (lambda (x) (cond - ((any (lambda (y) - (and (type-array y) - (type-auto-expand? y) - (eq? x (get-array-length func y)))) - (func-c-args func)) + ((find (lambda (y) + (and (type-array y) + (type-auto-expand? y) + (eq? x (get-array-length func y)))) + (func-c-args func)) => (lambda (y) (cat "len" (type-index y)))) (else (write x))))) ((or (type-result? arg) (type-array arg)) @@ -785,7 +785,7 @@ c-args) (cat ")")) (cond - ((any type-link? (func-c-args func)) + ((find type-link? (func-c-args func)) => (lambda (a) (string-append "arg" (type-index-string a)))) (else #f))) (cat ";\n") @@ -842,7 +842,7 @@ "") "err) {\n" (cond - ((any type-auto-expand? (func-c-args func)) + ((find type-auto-expand? (func-c-args func)) => (lambda (a) (lambda () (let ((len (get-array-length func a)) @@ -1100,8 +1100,8 @@ ((pair? ls) (let* ((a (car ls)) (field - (any (lambda (f) (and (pair? f) (eq? a (cadr f)))) - (cddr x)))) + (find (lambda (f) (and (pair? f) (eq? a (cadr f)))) + (cddr x)))) (if field (cat " r->" (cadr field) " = " (lambda ()