Added vector-for-each

This commit is contained in:
Abdulaziz Ghuloum 2007-08-28 17:24:53 -04:00
parent 5321868952
commit d1221276b9
9 changed files with 70 additions and 5 deletions

2
BUGS
View File

@ -1,5 +1,7 @@
BUG: BUG:
* symbol calls are not checking for non-procedure.
* set! on global names is not working.
Email Will Clinger regarding: Email Will Clinger regarding:

View File

@ -1,7 +1,7 @@
CFLAGS = -I/opt/local/include -Wall -DNDEBUG -O3 #-fomit-frame-pointer CFLAGS = -I/opt/local/include -Wall -DNDEBUG -O3 #-fomit-frame-pointer
#CFLAGS = -I/opt/local/include -Wall -g #CFLAGS = -I/opt/local/include -Wall -g
LDFLAGS = -L/opt/local/lib -g -ldl -lgmp -lz #-rdynamic LDFLAGS = -L/opt/local/lib -g -ldl -lgmp -lz -lm #-rdynamic
CC = gcc CC = gcc
all: ikarus all: ikarus

Binary file not shown.

View File

@ -182,6 +182,7 @@ ik_relocate_code(ikp code){
fprintf(stderr, "foreign name is not a bytevector\n"); fprintf(stderr, "foreign name is not a bytevector\n");
exit(-1); exit(-1);
} }
dlerror();
void* sym = dlsym(RTLD_DEFAULT, name); void* sym = dlsym(RTLD_DEFAULT, name);
char* err = dlerror(); char* err = dlerror();
if(err){ if(err){

View File

@ -189,7 +189,7 @@ int main(int argc, char** argv){
struct sigaction * restrict oact); struct sigaction * restrict oact);
#endif #endif
void handler(int signo, struct __siginfo* info, ucontext_t* uap){ void handler(int signo, struct __siginfo* info, void* uap){
the_pcb->engine_counter = -1; the_pcb->engine_counter = -1;
the_pcb->interrupted = 1; the_pcb->interrupted = 1;
} }

Binary file not shown.

View File

@ -1,11 +1,11 @@
(library (ikarus vectors) (library (ikarus vectors)
(export make-vector vector vector-length vector-ref vector-set! (export make-vector vector vector-length vector-ref vector-set!
vector->list list->vector vector-map) vector->list list->vector vector-map vector-for-each)
(import (import
(except (ikarus) make-vector vector (except (ikarus) make-vector vector
vector-length vector-ref vector-set! vector-length vector-ref vector-set!
vector->list list->vector vector-map) vector->list list->vector vector-map vector-for-each)
(ikarus system $fx) (ikarus system $fx)
(ikarus system $pairs) (ikarus system $pairs)
(ikarus system $vectors)) (ikarus system $vectors))
@ -191,4 +191,65 @@
(f i ($cdr v*)))))) (f i ($cdr v*))))))
ac))])))]))) ac))])))])))
(module (vector-for-each)
(define who 'vector-for-each)
(define vector-for-each
(case-lambda
[(p v)
(unless (procedure? p)
(error who "~s is not a procedure" p))
(unless (vector? v)
(error who "~s is not a vector" v))
(let f ([p p] [v v] [i 0] [n (vector-length v)])
(cond
[($fx= i n) (void)]
[else
(p (vector-ref v i))
(f p v ($fxadd1 i) n)]))]
[(p v0 v1)
(unless (procedure? p)
(error who "~s is not a procedure" p))
(unless (vector? v0)
(error who "~s is not a vector" v0))
(unless (vector? v1)
(error who "~s is not a vector" v1))
(let ([n (vector-length v0)])
(unless ($fx= n ($vector-length v1))
(error who "length mismatch between ~s and ~s" v0 v1))
(let f ([p p] [v0 v0] [v1 v1] [i 0] [n n])
(cond
[($fx= i n) (void)]
[else
(p ($vector-ref v0 i) ($vector-ref v1 i))
(f p v0 v1 ($fxadd1 i) n)])))]
[(p v0 v1 . v*)
(unless (procedure? p)
(error who "~s is not a procedure" p))
(unless (vector? v0)
(error who "~s is not a vector" v0))
(unless (vector? v1)
(error who "~s is not a vector" v1))
(let ([n (vector-length v0)])
(unless ($fx= n ($vector-length v1))
(error who "length mismatch between ~s and ~s" v0 v1))
(let f ([v* v*] [n n])
(unless (null? v*)
(let ([a ($car v*)])
(unless (vector? a)
(error who "~s is not a vector" a))
(unless ($fx= ($vector-length a) n)
(error who "length mismatch")))
(f ($cdr v*) n)))
(let f ([p p] [v0 v0] [v1 v1] [v* v*] [i 0] [n n])
(cond
[($fx= i n) (void)]
[else
(apply p ($vector-ref v0 i) ($vector-ref v1 i)
(let f ([i i] [v* v*])
(if (null? v*)
'()
(cons ($vector-ref ($car v*) i)
(f i ($cdr v*))))))
(f p v0 v1 v* ($fxadd1 i) n)])))])))
) )

View File

@ -348,6 +348,7 @@
[list->vector i r] [list->vector i r]
[vector->list i r] [vector->list i r]
[vector-map i r] [vector-map i r]
[vector-for-each i r]
[make-bytevector i] [make-bytevector i]
[bytevector-length i] [bytevector-length i]
[bytevector-s8-ref i] [bytevector-s8-ref i]

View File

@ -223,7 +223,7 @@
[vector C ba] [vector C ba]
[vector->list C ba] [vector->list C ba]
[vector-fill! S ba] [vector-fill! S ba]
[vector-for-each S ba] [vector-for-each C ba]
[vector-length C ba] [vector-length C ba]
[vector-map C ba] [vector-map C ba]
[vector-ref C ba] [vector-ref C ba]