conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* Added find.

This commit is contained in:
Abdulaziz Ghuloum 2007-09-10 17:09:19 -04:00
parent 66541809e1
commit dd968d389d
4 changed files with 30 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

31
src/ikarus.lists.ss
View File

@ -1,14 +1,14 @@
(library (ikarus lists) (library (ikarus lists)
(export $memq list? list cons* make-list append length list-ref reverse (export $memq list? list cons* make-list append length list-ref reverse
last-pair memq memp memv member assq assp assv assoc last-pair memq memp memv member find assq assp assv assoc
remq remv remove remp filter map for-each andmap ormap list-tail) remq remv remove remp filter map for-each andmap ormap list-tail)
(import (import
(ikarus system $fx) (ikarus system $fx)
(ikarus system $pairs) (ikarus system $pairs)
(except (ikarus) list? list cons* make-list append reverse (except (ikarus) list? list cons* make-list append reverse
last-pair length list-ref memq memp memv member assq last-pair length list-ref memq memp memv member find
assp assv assoc remq remv remove remp filter assq assp assv assoc remq remv remove remp filter
map for-each andmap ormap list-tail)) map for-each andmap ormap list-tail))
(define $memq (define $memq
@ -274,6 +274,31 @@
(error 'memp "~s is not a procedure" p)) (error 'memp "~s is not a procedure" p))
(race ls ls ls p)))) (race ls ls ls p))))
(define find
(letrec ([race
(lambda (h t ls p)
(if (pair? h)
(let ([a ($car h)])
(if (p a)
a
(let ([h ($cdr h)])
(if (pair? h)
(let ([a ($car h)])
(if (p a)
a
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls p)
(error 'find "circular list ~s" ls))))
(if (null? h)
'#f
(error 'find "~s is not a proper list" ls))))))
(if (null? h)
'#f
(error 'find "~s is not a proper list" ls))))])
(lambda (p ls)
(unless (procedure? p)
(error 'find "~s is not a procedure" p))
(race ls ls ls p))))
(define assq (define assq
(letrec ([race (letrec ([race

1
src/makefile.ss
View File

@ -333,6 +333,7 @@
[remv i] [remv i]
[remove i] [remove i]
[filter i] [filter i]
[find i]
[list-sort i] [list-sort i]
[vector-sort i] [vector-sort i]
[vector-sort! i] [vector-sort! i]

2
src/todo-r6rs.ss
View File

@ -505,7 +505,7 @@
[assv C ls se] [assv C ls se]
[cons* C ls] [cons* C ls]
[filter C ls] [filter C ls]
[find S ls] [find C ls]
[fold-left S ls] [fold-left S ls]
[fold-right S ls] [fold-right S ls]
[for-all S ls] [for-all S ls]