suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix `vector-map' error message

Browse Source 
Closes PR 11828
This commit is contained in:
Matthew Flatt 2011-04-14 11:33:57 -06:00
parent 0acdd67d52
commit e734cd6127
2 changed files with 29 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
collects/racket/vector.rkt
View File

@ -69,19 +69,14 @@
;; uses name for error reporting ;; uses name for error reporting
(define (varargs-check f v vs name) (define (varargs-check f v vs name)
(unless (procedure? f) (unless (procedure? f)
(raise-type-error name "procedure" 0 f)) (apply raise-type-error name "procedure" 0 f v vs))
(unless (procedure-arity-includes? f (add1 (length vs)))
(raise-type-error
name
(format "procedure (arity ~a)" (add1 (length vs)))
0 f))
(unless (vector? v) (unless (vector? v)
(raise-type-error name "vector" 1 v)) (apply raise-type-error name "vector" 1 f v vs))
(let ([len (unsafe-vector-length v)]) (let ([len (unsafe-vector-length v)])
(for ([e (in-list vs)] (for ([e (in-list vs)]
[i (in-naturals 2)]) [i (in-naturals 2)])
(unless (vector? e) (unless (vector? e)
(raise-type-error name "vector" e i)) (apply raise-type-error name "vector" e i f v vs))
(unless (= len (unsafe-vector-length e)) (unless (= len (unsafe-vector-length e))
(raise (raise
(make-exn:fail:contract (make-exn:fail:contract
@ -96,6 +91,13 @@
(format "given ~a arguments total" (format "given ~a arguments total"
(sub1 (length args)))))) (sub1 (length args))))))
(current-continuation-marks))))) (current-continuation-marks)))))
(unless (procedure-arity-includes? f (add1 (length vs)))
(raise-mismatch-error
name
(format
"arity mismatch (expected arity ~a to match number of supplied vectors): "
(add1 (length vs)))
f))
len)) len))
(define (vector-map f v . vs) (define (vector-map f v . vs)

20
collects/tests/racket/vector.rktl
View File

@ -195,7 +195,6 @@
(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 +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"))) (err/rt-test (vector-argmax (lambda (x) x) (vector)) (check-regs #rx"vector-argmax" #rx"non-empty vector")))
;; vector-mem{ber,v,q} ;; vector-mem{ber,v,q}
(test 0 vector-member 7 #(7 1 2)) (test 0 vector-member 7 #(7 1 2))
@ -209,6 +208,25 @@
(test #f vector-memv (cons 1 2) (vector 7 (cons 1 2) 2)) (test #f vector-memv (cons 1 2) (vector 7 (cons 1 2) 2))
(test 1 vector-member (cons 1 2) (vector 7 (cons 1 2) 2)) (test 1 vector-member (cons 1 2) (vector 7 (cons 1 2) 2))
;; ---------------------------------------- vector-map
(let ()
(define ((check-regs . regexps) exn)
(and (exn:fail? exn)
(andmap (λ (reg) (regexp-match reg (exn-message exn)))
regexps)))
(test #(2) vector-map add1 #(1))
(test #(1 2 3) vector-map (lambda (x y) (max x y)) #(1 -2 -3) #(0 2 3))
(let ([vec (vector 1 -2 -3)])
(test #(1 2 3) vector-map! (lambda (x y) (max x y)) vec #(0 2 3))
(test #(1 2 3) values vec))
(err/rt-test (vector-map 1 #()) (check-regs #rx"vector-map" #rx"<procedure>"))
(err/rt-test (vector-map (lambda (x) x) 1) (check-regs #rx"vector-map" #rx"<vector>"))
(err/rt-test (vector-map (lambda (x) x) #() 1) (check-regs #rx"vector-map" #rx"<vector>"))
(err/rt-test (vector-map (lambda (x) x) #() #(1)) (check-regs #rx"vector-map" #rx"same size"))
(err/rt-test (vector-map (lambda (x) x) #() #() #()) (check-regs #rx"vector-map" #rx"arity mismatch")))
;; ---------- check no collisions with srfi/43 ---------- ;; ---------- check no collisions with srfi/43 ----------
#;(test (void) #;(test (void)