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

* Added remp and assp

This commit is contained in:
Abdulaziz Ghuloum 2007-09-10 15:56:15 -04:00
parent 009a25ad30
commit fc67c0e155
4 changed files with 67 additions and 8 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.

63
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 memv member assq assv assoc last-pair memq memp memv member assq assp assv assoc
map for-each andmap ormap list-tail) 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 memv member assq assv last-pair length list-ref memq memp memv member assq
assoc map for-each andmap ormap list-tail)) assp assv assoc map for-each andmap ormap list-tail))
(define $memq (define $memq
(lambda (x ls) (lambda (x ls)
@ -248,6 +248,32 @@
(lambda (x ls) (lambda (x ls)
(race ls ls ls x)))) (race ls ls ls x))))
(define memp
(letrec ([race
(lambda (h t ls p)
(if (pair? h)
(if (p ($car h))
h
(let ([h ($cdr h)])
(if (pair? h)
(if (p ($car h))
h
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls p)
(error 'memp "circular list ~s" ls)))
(if (null? h)
'#f
(error 'memp "~s is not a proper list" ls)))))
(if (null? h)
'#f
(error 'memp "~s is not a proper list" ls))))])
(lambda (p ls)
(unless (procedure? p)
(error 'memp "~s is not a procedure" p))
(race ls ls ls p))))
(define assq (define assq
(letrec ([race (letrec ([race
(lambda (x h t ls) (lambda (x h t ls)
@ -276,6 +302,37 @@
(lambda (x ls) (lambda (x ls)
(race x ls ls ls)))) (race x ls ls ls))))
(define assp
(letrec ([race
(lambda (p h t ls)
(if (pair? h)
(let ([a ($car h)] [h ($cdr h)])
(if (pair? a)
(if (p ($car a))
a
(if (pair? h)
(if (not (eq? h t))
(let ([a ($car h)])
(if (pair? a)
(if (p ($car a))
a
(race p ($cdr h) ($cdr t) ls))
(error 'assp "malformed alist ~s"
ls)))
(error 'assp "circular list ~s" ls))
(if (null? h)
#f
(error 'assp "~s is not a proper list" ls))))
(error 'assp "malformed alist ~s" ls)))
(if (null? h)
#f
(error 'assp "~s is not a proper list" ls))))])
(lambda (p ls)
(unless (procedure? p)
(error 'assp "~s is not a procedure" p))
(race p ls ls ls))))
(define assv (define assv
(letrec ([race (letrec ([race
(lambda (x h t ls) (lambda (x h t ls)

2
src/makefile.ss
View File

@ -321,9 +321,11 @@
[reverse i r] [reverse i r]
[length i r] [length i r]
[assq i r] [assq i r]
[assp i r]
[assv i r] [assv i r]
[assoc i r] [assoc i r]
[memq i r] [memq i r]
[memp i r]
[memv i r] [memv i r]
[member i r] [member i r]
[list-sort i] [list-sort i]

10
src/todo-r6rs.ss
View File

@ -500,7 +500,7 @@
[call-with-string-output-port D ip] [call-with-string-output-port D ip]
;;; ;;;
[assoc C ls se] [assoc C ls se]
[assp S ls] [assp C ls]
[assq C ls se] [assq C ls se]
[assv C ls se] [assv C ls se]
[cons* C ls] [cons* C ls]
@ -511,14 +511,14 @@
[for-all S ls] [for-all S ls]
[exists S ls] [exists S ls]
[member C ls se] [member C ls se]
[memp S ls] [memp C ls]
[memq C ls se] [memq C ls se]
[memv C ls se] [memv C ls se]
[partition S ls] [partition S ls]
[remove C ls] [remove S ls]
[remp S ls] [remp S ls]
[remq C ls] [remq S ls]
[remv C ls] [remv S ls]
;;; ;;;
[set-car! C mp se] [set-car! C mp se]
[set-cdr! C mp se] [set-cdr! C mp se]