ikarus/scheme/ikarus.vectors.ss

267 lines
9.1 KiB
Scheme

(library (ikarus vectors)
(export make-vector vector vector-length vector-ref vector-set!
vector->list list->vector vector-map vector-for-each
vector-fill!)
(import
(except (ikarus) make-vector vector
vector-length vector-ref vector-set!
vector->list list->vector vector-map vector-for-each
vector-fill!)
(ikarus system $fx)
(ikarus system $pairs)
(ikarus system $vectors))
(define vector-length
(lambda (x)
(unless (vector? x)
(error 'vector-length "~s is not a vector" x))
($vector-length x)))
(module (make-vector)
(define fill!
(lambda (v i n fill)
(cond
[($fx= i n) v]
[else
($vector-set! v i fill)
(fill! v ($fx+ i 1) n fill)])))
(define make-vector
(case-lambda
[(n) (make-vector n (void))]
[(n fill)
(unless (and (fixnum? n) ($fx>= n 0))
(error 'make-vector "~s is not a valid length" n))
(fill! ($make-vector n) 0 n fill)])))
(define vector
;;; FIXME: add case-lambda
(letrec ([length
(lambda (ls n)
(cond
[(null? ls) n]
[else (length ($cdr ls) ($fx+ n 1))]))]
[loop
(lambda (v ls i n)
(cond
[($fx= i n) v]
[else
($vector-set! v i ($car ls))
(loop v ($cdr ls) ($fx+ i 1) n)]))])
(lambda ls
(let ([n (length ls 0)])
(let ([v (make-vector n)])
(loop v ls 0 n))))))
(define vector-ref
(lambda (v i)
(unless (vector? v)
(error 'vector-ref "~s is not a vector" v))
(unless (fixnum? i)
(error 'vector-ref "~s is not a valid index" i))
(unless (and ($fx< i ($vector-length v))
($fx<= 0 i))
(error 'vector-ref "index ~s is out of range for ~s" i v))
($vector-ref v i)))
(define vector-set!
(lambda (v i c)
(unless (vector? v)
(error 'vector-set! "~s is not a vector" v))
(unless (fixnum? i)
(error 'vector-set! "~s is not a valid index" i))
(unless (and ($fx< i ($vector-length v))
($fx<= 0 i))
(error 'vector-set! "index ~s is out of range for ~s" i v))
($vector-set! v i c)))
(define vector->list
(lambda (v)
(define f
(lambda (v i ls)
(cond
[($fx< i 0) ls]
[else
(f v ($fxsub1 i) (cons ($vector-ref v i) ls))])))
(if (vector? v)
(let ([n ($vector-length v)])
(if ($fxzero? n)
'()
(f v ($fxsub1 n) '())))
(error 'vector->list "~s is not a vector" v))))
(define list->vector
(letrec ([race
(lambda (h t ls n)
(if (pair? h)
(let ([h ($cdr h)])
(if (pair? h)
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls ($fx+ n 2))
(error 'list->vector "circular list ~s" ls))
(if (null? h)
($fx+ n 1)
(error 'list->vector "~s is not a proper list" ls))))
(if (null? h)
n
(error 'list->vector "~s is not a proper list" ls))))]
[fill
(lambda (v i ls)
(cond
[(null? ls) v]
[else
(let ([c ($car ls)])
($vector-set! v i c)
(fill v ($fxadd1 i) (cdr ls)))]))])
(lambda (ls)
(let ([n (race ls ls ls 0)])
(let ([v (make-vector n)])
(fill v 0 ls))))))
(module (vector-map)
(define who 'vector-map)
(define (ls->vec ls n)
(let f ([v ($make-vector n)]
[n n]
[ls ls])
(cond
[(null? ls) v]
[else
(let ([n ($fxsub1 n)])
($vector-set! v n ($car ls))
(f v n ($cdr ls)))])))
(define vector-map
(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)] [ac '()])
(cond
[($fx= i n) (ls->vec ac n)]
[else
(f p v ($fxadd1 i) n (cons (p (vector-ref v i)) ac))]))]
[(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] [ac '()])
(cond
[($fx= i n) (ls->vec ac n)]
[else
(f p v0 v1 ($fxadd1 i) n
(cons (p ($vector-ref v0 i) ($vector-ref v1 i)) ac))])))]
[(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] [ac '()])
(cond
[($fx= i n) (ls->vec ac n)]
[else
(f p v0 v1 v* ($fxadd1 i) n
(cons
(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*))))))
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)])))])))
(define (vector-fill! v fill)
(unless (vector? v)
(error 'vector-fill! "~s is not a vector" v))
(let f ([v v] [i 0] [n ($vector-length v)] [fill fill])
(unless ($fx= i n)
($vector-set! v i fill)
(f v ($fxadd1 i) n fill))))
)