New `scheme/vector' library.
svn: r16511
This commit is contained in:
Sam Tobin-Hochstadt
parent
26be8b9db6
commit
149e695a55
|
|
@ -11,6 +11,7 @@
|
|||
scheme/tcp
|
||||
scheme/udp
|
||||
scheme/list
|
||||
scheme/vector
|
||||
scheme/string
|
||||
scheme/function
|
||||
scheme/path
|
||||
|
|
@ -36,7 +37,8 @@
|
|||
scheme/tcp
|
||||
scheme/udp
|
||||
scheme/list
|
||||
scheme/string
|
||||
scheme/vector
|
||||
scheme/string
|
||||
scheme/function
|
||||
scheme/path
|
||||
scheme/file
|
||||
|
|
|
|||
200
collects/scheme/vector.ss
Normal file
200
collects/scheme/vector.ss
Normal file
|
|
@ -0,0 +1,200 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/unsafe/ops scheme/list)
|
||||
(provide vector-copy vector-map vector-map! vector-append
|
||||
vector-take vector-drop vector-split-at
|
||||
vector-take-right vector-drop-right vector-split-at-right
|
||||
vector-filter vector-filter-not
|
||||
vector-count vector-argmin vector-argmax)
|
||||
|
||||
;; unchecked version of `vector-copy'
|
||||
;; used ad the implementation of many functions in this file
|
||||
(define (vector-copy* v start end)
|
||||
(define new-v (make-vector (- end start)))
|
||||
(vector-copy! new-v 0 v start end)
|
||||
new-v)
|
||||
|
||||
(define (vector-copy v [start 0] [end (and (vector? v) (vector-length v))])
|
||||
(unless (vector? v)
|
||||
(raise-type-error 'vector-copy "vector" v))
|
||||
(unless (exact-nonnegative-integer? start)
|
||||
(raise-type-error 'vector-copy "non-negative exact integer" 1 start))
|
||||
(let ([len (vector-length v)])
|
||||
(unless (and (<= 0 start) (< start len))
|
||||
(raise-mismatch-error
|
||||
'vector-copy
|
||||
(format "starting index ~e out of range [~e, ~e] for vector" start 0 len) v))
|
||||
(unless (and (<= start end) (<= end len))
|
||||
(raise-mismatch-error
|
||||
'vector-copy
|
||||
(format "ending index ~e out of range [~e, ~e] for vector ~e" start len) v))
|
||||
(vector-copy* v start end)))
|
||||
|
||||
;; do vector-map, putting the result in `target'
|
||||
;; length is passed to save the computation
|
||||
(define (vector-map/update f target length vs)
|
||||
(for ([i (in-range length)])
|
||||
(unsafe-vector-set!
|
||||
target i
|
||||
(apply f (map (lambda (vec) (unsafe-vector-ref vec i)) vs)))))
|
||||
|
||||
;; like scheme_make_args_string in the C code
|
||||
(define (make-args-string l)
|
||||
(apply string-append (add-between l " ")))
|
||||
|
||||
;; check that `v' is a vector
|
||||
;; that `v' and all the `vs' have the same length
|
||||
;; and that `f' takes |v + vs| args
|
||||
;; uses name for error reporting
|
||||
(define (varargs-check f v vs name)
|
||||
(unless (procedure? f)
|
||||
(raise-type-error name "procedure" 0 f))
|
||||
(unless (procedure-arity-includes? f (add1 (length vs)))
|
||||
(raise-type-error name "procedure that accepts ~e arguments" 0 f))
|
||||
(unless (vector? v)
|
||||
(raise-type-error name "vector" 1 v))
|
||||
(let ([len (unsafe-vector-length v)])
|
||||
(for ([e (in-list vs)]
|
||||
[i (in-naturals 2)])
|
||||
(unless (vector? e)
|
||||
(raise-type-error name "vector" e i))
|
||||
(unless (= len (unsafe-vector-length e))
|
||||
(raise (make-exn:fail:contract
|
||||
(format "~e: all vectors must have same size; arguments were: ~e" (make-args-string (list* f v vs)))
|
||||
(current-continuation-marks)))))
|
||||
len))
|
||||
|
||||
(define (vector-map f v . vs)
|
||||
(let* ([len (varargs-check f v vs 'vector-map)]
|
||||
[new-v (make-vector len)])
|
||||
(vector-map/update f new-v len (cons v vs))
|
||||
new-v))
|
||||
|
||||
(define (vector-map! f v . vs)
|
||||
(define len (varargs-check f v vs 'vector-map!))
|
||||
(vector-map/update f v len (cons v vs))
|
||||
v)
|
||||
|
||||
;; check that `v' is a vector and that `f' takes one arg
|
||||
;; uses name for error reporting
|
||||
(define (one-arg-check f v name)
|
||||
(unless (procedure? f)
|
||||
(raise-type-error name "procedure" 0 f))
|
||||
(unless (procedure-arity-includes? f 1)
|
||||
(raise-type-error name "procedure that accepts 1 argument" 0 f)))
|
||||
|
||||
(define (vector-filter f v)
|
||||
(one-arg-check f v 'vector-filter)
|
||||
(list->vector (for/list ([i (in-vector v)]
|
||||
#:when (f i))
|
||||
i)))
|
||||
|
||||
(define (vector-filter-not f v)
|
||||
(one-arg-check f v 'vector-filter-not)
|
||||
(list->vector (for/list ([i (in-vector v)]
|
||||
#:when (not (f i)))
|
||||
i)))
|
||||
|
||||
(define (vector-count f v . vs)
|
||||
(unless (and (procedure? f) (procedure-arity-includes? f (add1 (length vs))))
|
||||
(raise-type-error
|
||||
'vector-count (format "procedure (arity ~a)" (add1 (length vs))) f))
|
||||
(unless (and (vector? v) (andmap vector? vs))
|
||||
(raise-type-error
|
||||
'vector-count "vector"
|
||||
(ormap (lambda (x) (and (not (list? x)) x)) (cons v vs))))
|
||||
(if (pair? vs)
|
||||
(let ([len (vector-length v)])
|
||||
(if (andmap (lambda (v) (= len (vector-length v))) vs)
|
||||
(for/fold ([c 0])
|
||||
([i (in-range len)]
|
||||
#:when
|
||||
(apply f
|
||||
(unsafe-vector-ref v i)
|
||||
(map (lambda (v) (unsafe-vector-ref v i)) vs)))
|
||||
(add1 c))
|
||||
(error 'vector-count "all vectors must have same size")))
|
||||
(for/fold ([cnt 0]) ([i (in-vector v)]
|
||||
#:when (f i))
|
||||
(add1 cnt))))
|
||||
|
||||
|
||||
|
||||
|
||||
(define (check-vector/index v n name)
|
||||
(unless (vector? v)
|
||||
(raise-type-error name "vector" v))
|
||||
(unless (exact-nonnegative-integer? n)
|
||||
(raise-type-error name "non-negative exact integer" n))
|
||||
(let ([len (unsafe-vector-length v)])
|
||||
(unless (<= 0 n len)
|
||||
(raise-mismatch-error
|
||||
name
|
||||
(format "index out of range [~e, ~e] for vector" 0 len)
|
||||
v))
|
||||
len))
|
||||
|
||||
(define (vector-take v n)
|
||||
(check-vector/index v n 'vector-take)
|
||||
(vector-copy* v 0 n))
|
||||
|
||||
(define (vector-drop v n)
|
||||
(vector-copy* v n (check-vector/index v n 'vector-drop)))
|
||||
|
||||
(define (vector-split-at v n)
|
||||
(let ([len (check-vector/index v n 'vector-split-at)])
|
||||
(values (vector-copy* v 0 n) (vector-copy* v n len))))
|
||||
|
||||
(define (vector-take-right v n)
|
||||
(let ([len (check-vector/index v n 'vector-take-right)])
|
||||
(vector-copy* v (unsafe-fx- len n) len)))
|
||||
|
||||
(define (vector-drop-right v n)
|
||||
(let ([len (check-vector/index v n 'vector-drop-right)])
|
||||
(vector-copy* v 0 (unsafe-fx- len n))))
|
||||
|
||||
(define (vector-split-at-right v n)
|
||||
(let ([len (check-vector/index v n 'vector-split-at-right)])
|
||||
(values (vector-copy* v 0 (unsafe-fx- len n))
|
||||
(vector-copy* v (unsafe-fx- len n) len))))
|
||||
|
||||
(define (vector-append v . vs)
|
||||
(for ([e (in-list (cons v vs))]
|
||||
[i (in-naturals)])
|
||||
(unless (vector? e)
|
||||
(raise-type-error 'vector-append "vector" e i)))
|
||||
(let* ([len (apply + (map unsafe-vector-length (cons v vs)))]
|
||||
[new-v (make-vector len)])
|
||||
(for ([e (apply in-sequences (in-vector v) (map in-vector vs))]
|
||||
[i (in-range len)])
|
||||
(unsafe-vector-set! new-v i e))
|
||||
new-v))
|
||||
|
||||
;; copied from `scheme/list'
|
||||
(define (mk-min cmp name f xs)
|
||||
(unless (and (procedure? f)
|
||||
(procedure-arity-includes? f 1))
|
||||
(raise-type-error name "procedure (arity 1)" f))
|
||||
(unless (and (vector? xs)
|
||||
(< 0 (unsafe-vector-length xs)))
|
||||
(raise-type-error name "non-empty vector" xs))
|
||||
(let ([init-min-var (f (unsafe-vector-ref xs 0))])
|
||||
(unless (real? init-min-var)
|
||||
(raise-type-error name "procedure that returns real numbers" f))
|
||||
(let-values
|
||||
([(min* min-var*)
|
||||
(for/fold ([min (unsafe-vector-ref xs 0)]
|
||||
[min-var init-min-var])
|
||||
([e (in-vector xs 1)])
|
||||
(let ([new-min (f e)])
|
||||
(unless (real? new-min)
|
||||
(raise-type-error name "procedure that returns real numbers" f))
|
||||
(cond
|
||||
[(cmp new-min min-var)
|
||||
(values e new-min)]
|
||||
[else (values min min-var)])))])
|
||||
min*)))
|
||||
|
||||
(define (vector-argmin f xs) (mk-min < 'vector-argmin f xs))
|
||||
(define (vector-argmax f xs) (mk-min > 'vector-argmax f xs))
|
||||
|
||||
|
|
@ -145,3 +145,155 @@ _i)] is the value produced by @scheme[(proc _i)].
|
|||
(build-vector 5 add1)
|
||||
]}
|
||||
|
||||
@; ----------------------------------------
|
||||
@section{Additional Vector Functions}
|
||||
|
||||
@note-lib[scheme/vector]
|
||||
@(define vec-eval (make-base-eval))
|
||||
@(interaction-eval #:eval vec-eval
|
||||
(require scheme/vector))
|
||||
|
||||
@defproc[(vector-map [proc procedure?] [vec vector?] ...+)
|
||||
vector?]{
|
||||
|
||||
Applies @scheme[proc] to the elements of the @scheme[vec]s from the
|
||||
first elements to the last. The @scheme[proc] argument must accept
|
||||
the same number of arguments as the number of supplied @scheme[vec]s,
|
||||
and all @scheme[vec]s must have the same number of elements. The
|
||||
result is a fresh vector containing each result of @scheme[proc] in
|
||||
order.
|
||||
|
||||
@mz-examples[#:eval vec-eval
|
||||
(vector-map + #(1 2) #(3 4))]
|
||||
}
|
||||
|
||||
@defproc[(vector-map! [proc procedure?] [vec vector?] ...+)
|
||||
vector?]{
|
||||
|
||||
Applies @scheme[proc] to the elements of the @scheme[vec]s from the
|
||||
first elements to the last. The @scheme[proc] argument must accept
|
||||
the same number of arguments as the number of supplied @scheme[vec]s,
|
||||
and all @scheme[vec]s must have the same number of elements. The
|
||||
each result of @scheme[proc] is inserted into the first @scheme[vec]
|
||||
at the index that the arguments to @scheme[proc] was taken from. The
|
||||
result is the first @scheme[vec].
|
||||
|
||||
@mz-examples[#:eval vec-eval
|
||||
(define v #(1 2 3 4))
|
||||
(vector-map! add1 v)
|
||||
v
|
||||
]}
|
||||
|
||||
@defproc[(vector-append [lst list?] ...) list?]{
|
||||
|
||||
Creates a fresh vector that contains all
|
||||
of the elements of the given vectors in order.
|
||||
|
||||
@mz-examples[#:eval vec-eval
|
||||
(vector-append #(1 2) #(3 4))]
|
||||
}
|
||||
|
||||
|
||||
@defproc[(vector-take [vec vector?] [pos exact-nonnegative-integer?]) list?]{
|
||||
Returns a fresh vector whose elements are the first @scheme[pos] elements of
|
||||
@scheme[vec]. If @scheme[vec] has fewer than
|
||||
@scheme[pos] elements, the @exnraise[exn:fail:contract].
|
||||
|
||||
@mz-examples[#:eval vec-eval
|
||||
(vector-take #(1 2 3 4) 2)
|
||||
]}
|
||||
|
||||
@defproc[(vector-take-right [vec vector?] [pos exact-nonnegative-integer?]) list?]{
|
||||
Returns a fresh vector whose elements are the last @scheme[pos] elements of
|
||||
@scheme[vec]. If @scheme[vec] has fewer than
|
||||
@scheme[pos] elements, the @exnraise[exn:fail:contract].
|
||||
|
||||
@mz-examples[#:eval vec-eval
|
||||
(vector-take-right #(1 2 3 4) 2)
|
||||
]}
|
||||
|
||||
@defproc[(vector-drop [vec vector?] [pos exact-nonnegative-integer?]) vector?]{
|
||||
Returns a fresh vector whose elements are the elements of @scheme[vec]
|
||||
after the first @scheme[pos] elements. If @scheme[vec] has fewer
|
||||
than @scheme[pos] elements, the @exnraise[exn:fail:contract].
|
||||
|
||||
@mz-examples[#:eval vec-eval
|
||||
(vector-drop #(1 2 3 4) 2)
|
||||
]}
|
||||
|
||||
@defproc[(vector-drop-right [vec vector?] [pos exact-nonnegative-integer?]) vector?]{
|
||||
Returns a fresh vector whose elements are the elements of @scheme[vec]
|
||||
before the first @scheme[pos] elements. If @scheme[vec] has fewer
|
||||
than @scheme[pos] elements, the @exnraise[exn:fail:contract].
|
||||
|
||||
@mz-examples[#:eval vec-eval
|
||||
(vector-drop-right #(1 2 3 4) 2)
|
||||
]}
|
||||
|
||||
@defproc[(vector-split-at [vec vector?] [pos exact-nonnegative-integer?])
|
||||
(values vector? vector?)]{
|
||||
Returns the same result as
|
||||
|
||||
@schemeblock[(values (vector-take vec pos) (vector-drop vec pos))]
|
||||
|
||||
except that it can be faster.
|
||||
|
||||
@mz-examples[#:eval vec-eval
|
||||
(vector-split-at #(1 2 3 4 5) 2)
|
||||
]}
|
||||
|
||||
@defproc[(vector-split-at-right [vec vector?] [pos exact-nonnegative-integer?])
|
||||
(values vector? vector?)]{
|
||||
Returns the same result as
|
||||
|
||||
@schemeblock[(values (vector-take-right vec pos) (vector-drop-right vec pos))]
|
||||
|
||||
except that it can be faster.
|
||||
|
||||
@mz-examples[#:eval vec-eval
|
||||
(vector-split-at-right #(1 2 3 4 5) 2)
|
||||
]}
|
||||
|
||||
|
||||
@defproc[(vector-copy [vec vector?] [start exact-nonnegative-integer?
|
||||
0] [end exact-nonnegative-integer? (vector-length v)]) vector?]{
|
||||
Creates a fresh vector of size @scheme[(- end start)], with all of the
|
||||
elements of @scheme[vec] from @scheme[start] (inclusive) to
|
||||
@scheme[end] (exclusive).
|
||||
|
||||
@mz-examples[#:eval vec-eval
|
||||
(vector-copy #(1 2 3 4))
|
||||
(vector-copy #(1 2 3 4) 3)
|
||||
(vector-copy #(1 2 3 4) 2 3)
|
||||
]
|
||||
}
|
||||
|
||||
@defproc[(vector-filter [pred procedure?] [vec vector?]) vector?]{
|
||||
Returns a fresh vector with the elements of @scheme[vec] for which
|
||||
@scheme[pred] produces a true value. The @scheme[pred] procedure is
|
||||
applied to each element from first to last.
|
||||
|
||||
@mz-examples[#:eval vec-eval
|
||||
(vector-filter even? '(1 2 3 4 5 6))
|
||||
]}
|
||||
|
||||
@defproc[(vector-filter-not [pred procedure?] [vec vector?]) vector?]{
|
||||
|
||||
Like @scheme[vector-filter], but the meaning of the @scheme[pred] predicate
|
||||
is reversed: the result is a vector of all items for which @scheme[pred]
|
||||
returns @scheme[#f].
|
||||
|
||||
@mz-examples[#:eval vec-eval
|
||||
(vector-filter-not even? '(1 2 3 4 5 6))
|
||||
]}
|
||||
|
||||
|
||||
@defproc[(vector-count [proc procedure?] [lst list?] ...+)
|
||||
list?]{
|
||||
|
||||
Returns @scheme[(vector-length (vector-filter proc lst ...))], but
|
||||
without building the intermediate list.}
|
||||
|
||||
vector-count
|
||||
vector-argmin
|
||||
vector-argmax
|
||||
|
|
@ -1270,51 +1270,6 @@
|
|||
(arity-test regexp-replace 3 3)
|
||||
(arity-test regexp-replace* 3 3)
|
||||
|
||||
(test #t vector? '#(0 (2 2 2 2) "Anna"))
|
||||
(test #t vector? '#())
|
||||
(arity-test vector? 1 1)
|
||||
(test '#(a b c) vector 'a 'b 'c)
|
||||
(test '#() vector)
|
||||
(test 3 vector-length '#(0 (2 2 2 2) "Anna"))
|
||||
(test 0 vector-length '#())
|
||||
(arity-test vector-length 1 1)
|
||||
(err/rt-test (vector-length "apple"))
|
||||
(test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5)
|
||||
(arity-test vector-ref 2 2)
|
||||
(err/rt-test (vector-ref "apple" 3))
|
||||
(err/rt-test (vector-ref #(4 5 6) 3) exn:application:mismatch?)
|
||||
(err/rt-test (vector-ref #() 0) exn:application:mismatch?)
|
||||
(err/rt-test (vector-ref #() (expt 2 100)) exn:application:mismatch?)
|
||||
(err/rt-test (vector-ref #(4 5 6) -1))
|
||||
(err/rt-test (vector-ref #(4 5 6) 2.0))
|
||||
(err/rt-test (vector-ref #(4 5 6) "2"))
|
||||
(test '#(0 ("Sue" "Sue") "Anna") 'vector-set
|
||||
(let ((vec (vector 0 '(2 2 2 2) "Anna")))
|
||||
(vector-set! vec 1 '("Sue" "Sue"))
|
||||
vec))
|
||||
(test '#(hi hi) make-vector 2 'hi)
|
||||
(test '#() make-vector 0)
|
||||
(test '#() make-vector 0 'a)
|
||||
(test 2048 vector-length (make-vector 2048 'a))
|
||||
(arity-test make-vector 1 2)
|
||||
(err/rt-test (make-vector "a" 'a))
|
||||
(err/rt-test (make-vector 1.0 'a))
|
||||
(err/rt-test (make-vector 10.2 'a))
|
||||
(err/rt-test (make-vector -1 'a))
|
||||
(err/rt-test (make-vector 1000000000000000000000 'a) exn:fail:out-of-memory?)
|
||||
(arity-test vector-set! 3 3)
|
||||
(err/rt-test (vector-set! #() 0 'x) exn:application:mismatch?)
|
||||
(err/rt-test (vector-set! #(1 2 3) -1 'x))
|
||||
(err/rt-test (vector-set! #(1 2 3) 3 'x) exn:application:mismatch?)
|
||||
(err/rt-test (vector-set! #(1 2 3) (expt 2 100) 'x) exn:application:mismatch?)
|
||||
(err/rt-test (vector-set! '(1 2 3) 2 'x))
|
||||
(err/rt-test (vector-set! #(1 2 3) "2" 'x))
|
||||
(define v (vector 1 2 3))
|
||||
(vector-fill! v 0)
|
||||
(test (quote #(0 0 0)) 'vector-fill! v)
|
||||
(arity-test vector-fill! 2 2)
|
||||
(err/rt-test (vector-fill! '(1 2 3) 0))
|
||||
|
||||
(test #t procedure? car)
|
||||
(test #f procedure? 'car)
|
||||
(test #t procedure? (lambda (x) (* x x)))
|
||||
|
|
@ -1896,6 +1851,7 @@
|
|||
(err/rt-test (list->string 'hello))
|
||||
(err/rt-test (list->string '(#\h . #\e)))
|
||||
(err/rt-test (list->string '(#\h 1 #\e)))
|
||||
|
||||
(test '(dah dah didah) vector->list '#(dah dah didah))
|
||||
(test '() vector->list '#())
|
||||
(test '#(dididit dah) list->vector '(dididit dah))
|
||||
|
|
@ -1906,6 +1862,7 @@
|
|||
(err/rt-test (list->vector 'hello))
|
||||
(err/rt-test (list->vector '(#\h . #\e)))
|
||||
|
||||
|
||||
(test-cont)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
|
||||
(load-in-sandbox "for.ss")
|
||||
(load-in-sandbox "list.ss")
|
||||
(load-in-sandbox "vector.ss")
|
||||
(load-in-sandbox "function.ss")
|
||||
(load-in-sandbox "dict.ss")
|
||||
(load-in-sandbox "promise.ss")
|
||||
|
|
|
|||
182
collects/tests/mzscheme/vector.ss
Normal file
182
collects/tests/mzscheme/vector.ss
Normal file
|
|
@ -0,0 +1,182 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(Section 'list)
|
||||
|
||||
(require scheme/vector)
|
||||
|
||||
|
||||
(test #t vector? '#(0 (2 2 2 2) "Anna"))
|
||||
(test #t vector? '#())
|
||||
(arity-test vector? 1 1)
|
||||
(test '#(a b c) vector 'a 'b 'c)
|
||||
(test '#() vector)
|
||||
(test 3 vector-length '#(0 (2 2 2 2) "Anna"))
|
||||
(test 0 vector-length '#())
|
||||
(arity-test vector-length 1 1)
|
||||
(err/rt-test (vector-length "apple"))
|
||||
(test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5)
|
||||
(arity-test vector-ref 2 2)
|
||||
(err/rt-test (vector-ref "apple" 3))
|
||||
(err/rt-test (vector-ref #(4 5 6) 3) exn:application:mismatch?)
|
||||
(err/rt-test (vector-ref #() 0) exn:application:mismatch?)
|
||||
(err/rt-test (vector-ref #() (expt 2 100)) exn:application:mismatch?)
|
||||
(err/rt-test (vector-ref #(4 5 6) -1))
|
||||
(err/rt-test (vector-ref #(4 5 6) 2.0))
|
||||
(err/rt-test (vector-ref #(4 5 6) "2"))
|
||||
(test '#(0 ("Sue" "Sue") "Anna") 'vector-set
|
||||
(let ((vec (vector 0 '(2 2 2 2) "Anna")))
|
||||
(vector-set! vec 1 '("Sue" "Sue"))
|
||||
vec))
|
||||
(test '#(hi hi) make-vector 2 'hi)
|
||||
(test '#() make-vector 0)
|
||||
(test '#() make-vector 0 'a)
|
||||
(test 2048 vector-length (make-vector 2048 'a))
|
||||
(arity-test make-vector 1 2)
|
||||
(err/rt-test (make-vector "a" 'a))
|
||||
(err/rt-test (make-vector 1.0 'a))
|
||||
(err/rt-test (make-vector 10.2 'a))
|
||||
(err/rt-test (make-vector -1 'a))
|
||||
(err/rt-test (make-vector 1000000000000000000000 'a) exn:fail:out-of-memory?)
|
||||
(arity-test vector-set! 3 3)
|
||||
(err/rt-test (vector-set! #() 0 'x) exn:application:mismatch?)
|
||||
(err/rt-test (vector-set! #(1 2 3) -1 'x))
|
||||
(err/rt-test (vector-set! #(1 2 3) 3 'x) exn:application:mismatch?)
|
||||
(err/rt-test (vector-set! #(1 2 3) (expt 2 100) 'x) exn:application:mismatch?)
|
||||
(err/rt-test (vector-set! '(1 2 3) 2 'x))
|
||||
(err/rt-test (vector-set! #(1 2 3) "2" 'x))
|
||||
(define v (vector 1 2 3))
|
||||
(vector-fill! v 0)
|
||||
(test (quote #(0 0 0)) 'vector-fill! v)
|
||||
(arity-test vector-fill! 2 2)
|
||||
(err/rt-test (vector-fill! '(1 2 3) 0))
|
||||
|
||||
|
||||
|
||||
;; ---------- vector-take/drop[-right] ----------
|
||||
(let ()
|
||||
(define-syntax-rule (vals-list expr)
|
||||
(call-with-values (lambda () expr) list))
|
||||
(define (split-at* l n) (vals-list (vector-split-at l n)))
|
||||
(define (split-at-right* l n) (vals-list (vector-split-at-right l n)))
|
||||
(define funs (list vector-take vector-drop vector-take-right vector-drop-right
|
||||
split-at* split-at-right*))
|
||||
(define tests
|
||||
;; -----args------ --take--- --drop--- --take-r--- --drop-r-
|
||||
'([(#(a b c d) 2) #(a b) #(c d) #(c d) #(a b) ]
|
||||
[(#(a b c d) 0) #() #(a b c d) #() #(a b c d)]
|
||||
[(#(a b c d) 4) #(a b c d) #() #(a b c d) #() ]))
|
||||
(for ([t tests]
|
||||
#:when #t
|
||||
[expect `(,@(cdr t)
|
||||
,(list (list-ref t 1) (list-ref t 2))
|
||||
,(list (list-ref t 4) (list-ref t 3)))]
|
||||
[fun funs])
|
||||
(apply test expect fun (car t)))
|
||||
(for ([fun funs])
|
||||
(arity-test fun 2 2)
|
||||
(err/rt-test (fun #(1 2 3) 2.0))
|
||||
(err/rt-test (fun #(1) '(1)))
|
||||
(err/rt-test (fun #(1) -1))
|
||||
(err/rt-test (fun #(1) 2) exn:application:mismatch?)))
|
||||
|
||||
;; ---------- vector-append ----------
|
||||
(let ()
|
||||
(test #() vector-append #())
|
||||
(test #() vector-append #() #())
|
||||
(test #(1 2) vector-append #(1 2) #())
|
||||
(test #(1 2) vector-append #() #(1 2))
|
||||
(test #(a b) vector-append #(a) #(b))
|
||||
(test #(a b c) vector-append #(a b) #() #(c))
|
||||
(test #(a b d c) vector-append #(a b) #(d) #(c)))
|
||||
|
||||
|
||||
;; ---------- vector-filter[-not] ----------
|
||||
(let ()
|
||||
(define f vector-filter)
|
||||
(define fn vector-filter-not)
|
||||
|
||||
(test #() f number? #())
|
||||
(test #() fn number? #())
|
||||
(test #(1 2 3) f number? #(1 a 2 b 3 c d))
|
||||
(test #(a b c d) fn number? #(1 a 2 b 3 c d))
|
||||
(test #() f string? #(1 a 2 b 3 c d))
|
||||
(test #(1 a 2 b 3 c d) fn string? #(1 a 2 b 3 c d))
|
||||
(err/rt-test (f 2 #(1 2 3)))
|
||||
(err/rt-test (fn 2 #(1 2 3)))
|
||||
(err/rt-test (f cons #(1 2 3)))
|
||||
(err/rt-test (fn cons #(1 2 3)))
|
||||
(arity-test f 2 2)
|
||||
(arity-test fn 2 2))
|
||||
|
||||
|
||||
;; ---------- vector-count ----------
|
||||
|
||||
(let ()
|
||||
(test 0 vector-count even? #())
|
||||
(test 4 vector-count even? #(0 2 4 6))
|
||||
(test 0 vector-count even? #(1 3 5 7))
|
||||
(test 2 vector-count even? #(1 2 3 4))
|
||||
(test 2 vector-count < #(1 2 3 4) #(4 3 2 1)))
|
||||
|
||||
;; ---------- vector-arg{min,max} ----------
|
||||
|
||||
(let ()
|
||||
|
||||
(define ((check-regs . regexps) exn)
|
||||
(and (exn:fail? exn)
|
||||
(andmap (λ (reg) (regexp-match reg (exn-message exn)))
|
||||
regexps)))
|
||||
|
||||
(test 'vector-argmin object-name vector-argmin)
|
||||
(test 1 vector-argmin (lambda (x) 0) (vector 1))
|
||||
(test 1 vector-argmin (lambda (x) x) (vector 1 2 3))
|
||||
(test 1 vector-argmin (lambda (x) 1) (vector 1 2 3))
|
||||
|
||||
(test 3
|
||||
'vector-argmin-makes-right-number-of-calls
|
||||
(let ([c 0])
|
||||
(vector-argmin (lambda (x) (set! c (+ c 1)) 0)
|
||||
(vector 1 2 3))
|
||||
c))
|
||||
|
||||
(test '(1 banana) vector-argmin car #((3 pears) (1 banana) (2 apples)))
|
||||
|
||||
(err/rt-test (vector-argmin 1 (vector 1)) (check-regs #rx"vector-argmin" #rx"procedure"))
|
||||
(err/rt-test (vector-argmin (lambda (x) x) 3) (check-regs #rx"vector-argmin" #rx"vector"))
|
||||
(err/rt-test (vector-argmin (lambda (x) x) (vector 1 #f)) (check-regs #rx"vector-argmin" #rx"procedure that returns real numbers"))
|
||||
(err/rt-test (vector-argmin (lambda (x) x) (vector #f)) (check-regs #rx"vector-argmin" #rx"procedure that returns real numbers"))
|
||||
|
||||
(err/rt-test (vector-argmin (lambda (x) x) (vector +i)) (check-regs #rx"vector-argmin" #rx"procedure that returns real numbers"))
|
||||
(err/rt-test (vector-argmin (lambda (x) x) (vector)) (check-regs #rx"vector-argmin" #rx"non-empty vector"))
|
||||
|
||||
(test 'vector-argmax object-name vector-argmax)
|
||||
(test 1 vector-argmax (lambda (x) 0) (vector 1))
|
||||
(test 3 vector-argmax (lambda (x) x) (vector 1 2 3))
|
||||
(test 1 vector-argmax (lambda (x) 1) (vector 1 2 3))
|
||||
|
||||
(test 3
|
||||
'vector-argmax-makes-right-number-of-calls
|
||||
(let ([c 0])
|
||||
(vector-argmax (lambda (x) (set! c (+ c 1)) 0)
|
||||
(vector 1 2 3))
|
||||
c))
|
||||
|
||||
(test '(3 pears) vector-argmax car #((3 pears) (1 banana) (2 apples)))
|
||||
|
||||
(err/rt-test (vector-argmax 1 (vector 1)) (check-regs #rx"vector-argmax" #rx"procedure"))
|
||||
(err/rt-test (vector-argmax (lambda (x) x) 3) (check-regs #rx"vector-argmax" #rx"vector"))
|
||||
(err/rt-test (vector-argmax (lambda (x) x) (vector 1 #f)) (check-regs #rx"vector-argmax" #rx"procedure that returns real numbers"))
|
||||
(err/rt-test (vector-argmax (lambda (x) x) (vector #f)) (check-regs #rx"vector-argmax" #rx"procedure that returns real numbers"))
|
||||
|
||||
(err/rt-test (vector-argmax (lambda (x) x) (vector +i)) (check-regs #rx"vector-argmax" #rx"procedure that returns real numbers"))
|
||||
(err/rt-test (vector-argmax (lambda (x) x) (vector)) (check-regs #rx"vector-argmax" #rx"non-empty vector")))
|
||||
|
||||
|
||||
|
||||
;; ---------- check no collisions with srfi/43 ----------
|
||||
#;(test (void)
|
||||
eval '(module foo scheme/base (require scheme/base srfi/43))
|
||||
(make-base-namespace))
|
||||
|
||||
(report-errs)
|
||||
Loading…
Reference in New Issue
Block a user