Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-22 07:09:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

changing SRFI-1 any to return the result of the pred

Browse source 
was previously returning the args as in find (thanks kiyokap)
This commit is contained in:
Alex Shinn 2011-06-29 23:37:23 +09:00
parent f415b01eee
commit e738a59989
5 changed files with 35 additions and 36 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
lib/chibi/optimize/rest.scm
View file

@ -19,7 +19,7 @@
(lambda (p a)
(match a
(((? (lambda (op) (eq? op cdr))) ($ Ref name (_ . (? lambda? lam))))
(let ((x (any (lambda (r)
(let ((x (find (lambda (r)
(and (eq? name (car r)) (eq? lam (cadr r))))
cdrs)))
(and x (list p f (+ (caddr x) 1)))))
@ -27,7 +27,7 @@
((? (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)
(let ((x (find (lambda (r)
(and (eq? name (car r)) (eq? lam (cadr r))))
cdrs)))
(and x (list p f (+ (caddr x) 1.0)))))
@ -80,7 +80,7 @@
(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))))
(find (lambda (r) (and (eq? name (car r)) (eq? f (cadr r))))
cdrs))))
(cond
((not r)

29
lib/init.scm
View file

@ -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

6
lib/srfi/1/search.scm
View file

@ -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)))

2
tools/chibi-doc
View file

@ -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)

8
tools/chibi-ffi
View file

@ -744,7 +744,7 @@
((and (not (type-default? arg)) (type-value arg))
=> (lambda (x)
(cond
((any (lambda (y)
((find (lambda (y)
(and (type-array y)
(type-auto-expand? y)
(eq? x (get-array-length func y))))
@ -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,7 +1100,7 @@
((pair? ls)
(let* ((a (car ls))
(field
(any (lambda (f) (and (pair? f) (eq? a (cadr f))))
(find (lambda (f) (and (pair? f) (eq? a (cadr f))))
(cddr x))))
(if field
(cat " r->" (cadr field) " = "