From e738a5998956e3842e6b6b57d0f34f4c86f0ae72 Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Wed, 29 Jun 2011 23:37:23 +0900
Subject: [PATCH] changing SRFI-1 any to return the result of the pred was
previously returning the args as in find (thanks kiyokap)
---
lib/chibi/optimize/rest.scm | 16 ++++++++--------
lib/init.scm | 29 +++++++++++++++++------------
lib/srfi/1/search.scm | 6 ------
tools/chibi-doc | 2 +-
tools/chibi-ffi | 18 +++++++++---------
5 files changed, 35 insertions(+), 36 deletions(-)
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 ()