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

more error-message conversion

Browse Source
This commit is contained in:
Matthew Flatt 2012-05-27 09:03:19 -06:00
parent 00ef7da640
commit 6eeb8fccbd
32 changed files with 468 additions and 480 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/racket/bool.rkt
View File

@ -13,12 +13,12 @@
(define (boolean=? x y)
(unless (and (boolean? x) (boolean? y))
(raise-type-error 'boolean=? "boolean" (if (boolean? x) 1 0) x y))
(raise-argument-error 'boolean=? "boolean?" (if (boolean? x) 1 0) x y))
(eq? x y))
(define (symbol=? x y)
(unless (and (symbol? x) (symbol? y))
(raise-type-error 'symbol=? "symbol" (if (symbol? x) 1 0) x y))
(raise-argument-error 'symbol=? "symbol?" (if (symbol? x) 1 0) x y))
(eq? x y))
(define-syntax (implies stx)

4
collects/racket/bytes.rkt
View File

@ -10,9 +10,9 @@
(define (bytes-join strs sep)
(cond [(not (and (list? strs) (andmap bytes? strs)))
(raise-type-error 'bytes-join "list-of-byte-strings" strs)]
(raise-argument-error 'bytes-join "(listof bytes?)" strs)]
[(not (bytes? sep))
(raise-type-error 'bytes-join "bytes" sep)]
(raise-argument-error 'bytes-join "bytes?" sep)]
[(null? strs) #""]
[(null? (cdr strs)) (car strs)]
[else (apply bytes-append (add-between strs sep))]))

4
collects/racket/fasl.rkt
View File

@ -6,7 +6,7 @@
(define (s-exp->fasl v [out #f])
(when out
(unless (output-port? out)
(raise-type-error 'fasl->s-exp "output-port or #f" out)))
(raise-argument-error 'fasl->s-exp "(or/c output-port? #f)" out)))
(let ([p (or out
(open-output-bytes))])
(parameterize ([current-namespace (make-base-namespace)])
@ -18,7 +18,7 @@
(define (fasl->s-exp b)
(unless (or (bytes? b)
(input-port? b))
(raise-type-error 'fasl->s-exp "bytes or input-port" b))
(raise-arguments-error 'fasl->s-exp "(or/c bytes? input-port?)" b))
(let ([p (if (bytes? b)
(open-input-bytes b)
b)])

72
collects/racket/file.rkt
View File

@ -51,7 +51,7 @@
(define (delete-directory/files path)
(unless (path-string? path)
(raise-type-error 'delete-directory/files "path or string" path))
(raise-argument-error 'delete-directory/files "path-string?" path))
(cond
[(or (link-exists? path) (file-exists? path))
(delete-file path)]
@ -126,20 +126,20 @@
(define (make-temporary-file [template "rkttmp~a"] [copy-from #f] [base-dir #f])
(with-handlers ([exn:fail:contract?
(lambda (x)
(raise-type-error 'make-temporary-file
"format string for 1 argument"
template))])
(raise-arguments-error 'make-temporary-file
"format string does not expect 1 argument"
"format string" template))])
(format template void))
(unless (or (not copy-from)
(path-string? copy-from)
(eq? copy-from 'directory))
(raise-type-error 'make-temporary-file
"path, valid-path string, 'directory, or #f"
copy-from))
(raise-argument-error 'make-temporary-file
"(or/c path-string? 'directory #f)"
copy-from))
(unless (or (not base-dir) (path-string? base-dir))
(raise-type-error 'make-temporary-file
"path, valid-path, string, or #f"
base-dir))
(raise-argument-error 'make-temporary-file
"(or/c path-string? #f)"
base-dir))
(let ([tmpdir (find-system-path 'temp-dir)])
(let loop ([s (current-seconds)]
[ms (inexact->exact (truncate (current-inexact-milliseconds)))])
@ -209,16 +209,16 @@
(case-lambda
[(path)
(unless (path-string? path)
(raise-type-error 'make-lock-file-name "path string" path))
(raise-argument-error 'make-lock-file-name "path-string?" path))
(let-values ([(dir name dir?) (split-path path)])
(if (eq? dir 'relative)
(make-pathless-lock-file-name name)
(make-lock-file-name dir name)))]
[(dir name)
(unless (path-string? dir)
(raise-type-error 'make-lock-file-name "path string" dir))
(raise-argument-error 'make-lock-file-name "path-string?" dir))
(unless (path-element? name)
(raise-type-error 'make-lock-file-name "path element" name))
(raise-argument-error 'make-lock-file-name "path-element?" name))
(build-path dir
(make-pathless-lock-file-name name))]))
@ -233,19 +233,19 @@
#:max-delay [max-delay 0.2])
(unless (or (path-string? fn) (eq? fn #f))
(raise-type-error 'call-with-file-lock/timeout "path-string? or #f" fn))
(raise-argument-error 'call-with-file-lock/timeout "(or/c path-string? #f)" fn))
(unless (or (eq? kind 'shared) (eq? kind 'exclusive))
(raise-type-error 'call-with-file-lock/timeout "'shared or 'exclusive" kind))
(raise-argument-error 'call-with-file-lock/timeout "(or/c 'shared 'exclusive)" kind))
(unless (and (procedure? thunk) (= (procedure-arity thunk) 0))
(raise-type-error 'call-with-file-lock/timeout "procedure (arity 0)" thunk))
(raise-argument-error 'call-with-file-lock/timeout "(-> any)" thunk))
(unless (and (procedure? thunk) (= (procedure-arity failure-thunk) 0))
(raise-type-error 'call-with-file-lock/timeout "procedure (arity 0)" failure-thunk))
(raise-argument-error 'call-with-file-lock/timeout "(-> any)" failure-thunk))
(unless (or (not lock-file) (path-string? lock-file))
(raise-type-error 'call-with-file-lock/timeout "path-string? or #f" lock-file))
(raise-argument-error 'call-with-file-lock/timeout "(or/c path-string? #f)" lock-file))
(unless (and (real? delay) (not (negative? delay)))
(raise-type-error 'call-with-file-lock/timeout "non-negative real" delay))
(raise-argument-error 'call-with-file-lock/timeout "(>=/c 0.0)" delay))
(unless (and (real? max-delay) (not (negative? max-delay)))
(raise-type-error 'call-with-file-lock/timeout "non-negative real" max-delay))
(raise-argument-error 'call-with-file-lock/timeout "(>=/c 0.0)" max-delay))
(define real-lock-file (or lock-file (make-lock-file-name fn)))
(let loop ([delay delay])
@ -430,10 +430,10 @@
#:lock-there timeout-lock-there)]
#:use-lock? [use-lock? #t])
(unless (symbol? name)
(raise-type-error 'get-preference "symbol" name))
(raise-argument-error 'get-preference "symbol?" name))
(unless (and (procedure? fail-thunk)
(procedure-arity-includes? fail-thunk 0))
(raise-type-error 'get-preference "procedure (arity 0)" fail-thunk))
(raise-argument-error 'get-preference "(-> any)" fail-thunk))
((let/ec esc
(let ([f (get-prefs refresh-cache? filename use-lock?
(and lock-there
@ -445,15 +445,17 @@
(define (put-preferences names vals [lock-there #f] [filename #f])
(unless (and (list? names) (andmap symbol? names))
(raise-type-error 'put-preferences "list of symbols" names))
(raise-argument-error 'put-preferences "(listof symbol?)" names))
(unless (list? vals)
(raise-type-error 'put-preferences "list" vals))
(raise-argument-error 'put-preferences "list?" vals))
(unless (= (length names) (length vals))
(raise-mismatch-error
(raise-arguments-error
'put-preferences
(format "the size of the name list (~a) does not match the size of the value list (~a): "
(length names) (length vals))
vals))
"the length of the name list does not match the length of the value list"
"name list length" (length names)
"value list length" (length vals)
"name list" names
"value list" vals))
(let-values ([(pref-file lock-file pref-dir)
(let ([filename (or filename (find-system-path 'pref-file))])
(let-values ([(base name dir?) (split-path filename)])
@ -586,11 +588,11 @@
(define (check-path who f)
(unless (path-string? f)
(raise-type-error who "path string" f)))
(raise-argument-error who "path-string?" f)))
(define (check-file-mode who file-mode)
(unless (memq file-mode '(binary text))
(raise-type-error who "'binary or 'text" file-mode)))
(raise-argument-error who "(or/c 'binary 'text)" file-mode)))
(define (file->x who f file-mode read-x x-append)
(check-path who f)
@ -621,7 +623,7 @@
(check-path 'file->list f)
(check-file-mode 'file->list file-mode)
(unless (and (procedure? r) (procedure-arity-includes? r 1))
(raise-type-error 'file->list "procedure (arity 1)" r))
(raise-argument-error 'file->list "(procedure-arity-includes/c 1)" r))
(call-with-input-file* f #:mode file-mode
(lambda (p) (for/list ([v (in-port r p)]) v))))
@ -640,11 +642,11 @@
(define (->file who f mode exists write)
(unless (path-string? f)
(raise-type-error who "path string" f))
(raise-argument-error who "path-string?" f))
(unless (memq mode '(binary text))
(raise-type-error who "'binary or 'text" mode))
(raise-argument-error who "(or/c 'binary 'text)" mode))
(unless (memq exists '(error append update replace truncate truncate/replace))
(raise-type-error who "'error, 'append, 'update, 'replace, 'truncate, or 'truncate/replace" exists))
(raise-argument-error who "(or/c 'error 'append 'update 'replace 'truncate 'truncate/replace)" exists))
(call-with-output-file* f #:mode mode #:exists exists write))
(define (display-to-file s f #:mode [mode 'binary] #:exists [exists 'error])
@ -658,7 +660,7 @@
#:exists [exists 'error]
#:separator [newline #"\n"])
(unless (list? l)
(raise-type-error 'display-lines-to-file "list" l))
(raise-argument-error 'display-lines-to-file "list?" l))
(->file 'display-lines-to-file f mode exists
(lambda (p) (do-lines->port l p newline))))

4
collects/racket/function.rkt
View File

@ -28,7 +28,7 @@
(make-keyword-procedure (lambda (_1 _2 . _3) (th)) proc))))]))
(define (negate f)
(unless (procedure? f) (raise-type-error 'negate "procedure" f))
(unless (procedure? f) (raise-argument-error 'negate "procedure?" f))
(let-values ([(arity) (procedure-arity f)] [(_ kwds) (procedure-keywords f)])
(case (and (null? kwds) arity) ; optimize some simple cases
[(0) (lambda () (not (f)))]
@ -40,7 +40,7 @@
;; The real code is here
(define (curry* f args kws kvs)
(unless (procedure? f)
(raise-type-error (if right? 'curryr 'curry) "procedure" f))
(raise-argument-error (if right? 'curryr 'curry) "procedure?" f))
(let* ([arity (procedure-arity f)]
[max-arity (cond [(integer? arity) arity]
[(arity-at-least? arity) #f]

8
collects/racket/generator.rkt
View File

@ -99,9 +99,9 @@
(set! cont (lambda () (set! state 'done) (apply values rs)))
(cont))))))
(define (err [what "send a value to"])
(raise-mismatch-error 'generator
(format "cannot ~a a ~a generator: " what state)
self))
(raise-arguments-error 'generator
(format "cannot ~a a ~a generator" what state)
"generator" self))
(define generator
(case-lambda
[() (if (eq? state 'running)
@ -130,7 +130,7 @@
(define (generator-state g)
(if (generator? g)
(g yield-tag)
(raise-type-error 'generator-state "generator" g)))
(raise-argument-error 'generator-state "generator?" g)))
(define-syntax-rule (infinite-generator body0 body ...)
(generator () (let loop () body0 body ... (loop))))

96
collects/racket/list.rkt
View File

@ -37,7 +37,7 @@
(define (first x)
(if (and (pair? x) (list? x))
(car x)
(raise-type-error 'first "non-empty list" x)))
(raise-argument-error 'first "(and/c list? (not/c empty?))" x)))
(define-syntax define-lgetter
(syntax-rules ()
@ -47,9 +47,10 @@
(let loop ([l l0] [pos npos])
(if (pair? l)
(if (eq? pos 1) (car l) (loop (cdr l) (sub1 pos)))
(raise-type-error
'name (format "list with ~a or more items" npos) l0)))
(raise-type-error 'name "list" l0)))]))
(raise-arguments-error 'name
"list contains too few elements"
"list" l0)))
(raise-argument-error 'name "list?" l0)))]))
(define-lgetter second 2)
(define-lgetter third 3)
(define-lgetter fourth 4)
@ -66,7 +67,7 @@
(if (pair? x)
(loop x (cdr x))
l))
(raise-type-error 'last-pair "pair" l)))
(raise-argument-error 'last-pair "pair?" l)))
(define (last l)
(if (and (pair? l) (list? l))
@ -74,12 +75,12 @@
(if (pair? x)
(loop x (cdr x))
(car l)))
(raise-type-error 'last "non-empty list" l)))
(raise-argument-error 'last "(and/c list? (not/c empty?))" l)))
(define (rest l)
(if (and (pair? l) (list? l))
(cdr l)
(raise-type-error 'rest "non-empty list" l)))
(raise-argument-error 'rest "(and/c list? (not/c empty?))" l)))
(define cons? (lambda (l) (pair? l)))
(define empty? (lambda (l) (null? l)))
@ -87,7 +88,7 @@
(define (make-list n x)
(unless (exact-nonnegative-integer? n)
(raise-type-error 'make-list "non-negative exact integer" n))
(raise-argument-error 'make-list "exact-nonnegative-integer?" n))
(let loop ([n n] [r '()])
(if (zero? n) r (loop (sub1 n) (cons x r)))))
@ -95,15 +96,20 @@
(define (drop* list n) ; no error checking, returns #f if index is too large
(if (zero? n) list (and (pair? list) (drop* (cdr list) (sub1 n)))))
(define (too-large who list n)
(raise-mismatch-error
(raise-arguments-error
who
(format "index ~e too large for list~a: "
n (if (list? list) "" " (not a proper list)"))
(if (list? list)
"index is too large for list"
"index reaches a non-pair")
"index" n
(if (list? list)
"list"
"in")
list))
(define (take list0 n0)
(unless (exact-nonnegative-integer? n0)
(raise-type-error 'take "non-negative exact integer" 1 list0 n0))
(raise-argument-error 'take "exact-nonnegative-integer?" 1 list0 n0))
(let loop ([list list0] [n n0])
(cond [(zero? n) '()]
[(pair? list) (cons (car list) (loop (cdr list) (sub1 n)))]
@ -111,7 +117,7 @@
(define (split-at list0 n0)
(unless (exact-nonnegative-integer? n0)
(raise-type-error 'split-at "non-negative exact integer" 1 list0 n0))
(raise-argument-error 'split-at "exact-nonnegative-integer?" 1 list0 n0))
(let loop ([list list0] [n n0] [pfx '()])
(cond [(zero? n) (values (reverse pfx) list)]
[(pair? list) (loop (cdr list) (sub1 n) (cons (car list) pfx))]
@ -120,14 +126,14 @@
(define (drop list n)
;; could be defined as `list-tail', but this is better for errors anyway
(unless (exact-nonnegative-integer? n)
(raise-type-error 'drop "non-negative exact integer" 1 list n))
(raise-argument-error 'drop "exact-nonnegative-integer?" 1 list n))
(or (drop* list n) (too-large 'drop list n)))
;; take/drop-right are originally from srfi-1, uses the same lead-pointer trick
(define (take-right list n)
(unless (exact-nonnegative-integer? n)
(raise-type-error 'take-right "non-negative exact integer" 1 list n))
(raise-argument-error 'take-right "exact-nonnegative-integer?" 1 list n))
(let loop ([list list]
[lead (or (drop* list n) (too-large 'take-right list n))])
;; could throw an error for non-lists, but be more like `take'
@ -137,7 +143,7 @@
(define (drop-right list n)
(unless (exact-nonnegative-integer? n)
(raise-type-error 'drop-right "non-negative exact integer" n))
(raise-argument-error 'drop-right "exact-nonnegative-integer?" n))
(let loop ([list list]
[lead (or (drop* list n) (too-large 'drop-right list n))])
;; could throw an error for non-lists, but be more like `drop'
@ -147,7 +153,7 @@
(define (split-at-right list n)
(unless (exact-nonnegative-integer? n)
(raise-type-error 'split-at-right "non-negative exact integer" n))
(raise-argument-error 'split-at-right "exact-nonnegative-integer?" n))
(let loop ([list list]
[lead (or (drop* list n) (too-large 'split-at-right list n))]
[pfx '()])
@ -172,7 +178,7 @@
;; General note: many non-tail recursive, which are just as fast in mzscheme
(define (add-between l x)
(cond [(not (list? l)) (raise-type-error 'add-between "list" 0 l x)]
(cond [(not (list? l)) (raise-argument-error 'add-between "list?" 0 l x)]
[(null? l) null]
[(null? (cdr l)) l]
[else (cons (car l)
@ -197,7 +203,7 @@
;; `no-key' is used to optimize the case for long lists, it could be done for
;; shorter ones too, but that adds a ton of code to the result (about 2k).
(define-syntax-rule (no-key x) x)
(unless (list? l) (raise-type-error 'remove-duplicates "list" l))
(unless (list? l) (raise-argument-error 'remove-duplicates "list?" l))
(let* ([len (length l)]
[h (cond [(<= len 1) #t]
[(<= len 40) #f]
@ -241,14 +247,20 @@
(cons x (loop l)))))))])])
(if key (loop key) (loop no-key)))])))
(define (filter-map f l . ls)
(unless (and (procedure? f) (procedure-arity-includes? f (add1 (length ls))))
(raise-type-error
'filter-map (format "procedure (arity ~a)" (add1 (length ls))) f))
(define (check-filter-arguments who f l ls)
(unless (procedure? f)
(raise-argument-error who "procedure?" f))
(unless (procedure-arity-includes? f (add1 (length ls)))
(raise-arguments-error who "mismatch between procedure arity and argument count"
"procedure" f
"expected arity" (add1 (length ls))))
(unless (and (list? l) (andmap list? ls))
(raise-type-error
'filter-map "proper list"
(ormap (lambda (x) (and (not (list? x)) x)) (cons l ls))))
(raise-argument-error
who "list?"
(ormap (lambda (x) (and (not (list? x)) x)) (cons l ls)))))
(define (filter-map f l . ls)
(check-filter-arguments 'filter-map f l ls)
(if (pair? ls)
(let ([len (length l)])
(if (andmap (lambda (l) (= len (length l))) ls)
@ -259,7 +271,7 @@
(if x
(cons x (loop (cdr l) (map cdr ls)))
(loop (cdr l) (map cdr ls))))))
(error 'filter-map "all lists must have same size")))
(raise-arguments-error 'filter-map "all lists must have same size")))
(let loop ([l l])
(if (null? l)
null
@ -268,13 +280,7 @@
;; very similar to `filter-map', one more such function will justify some macro
(define (count f l . ls)
(unless (and (procedure? f) (procedure-arity-includes? f (add1 (length ls))))
(raise-type-error
'count (format "procedure (arity ~a)" (add1 (length ls))) f))
(unless (and (list? l) (andmap list? ls))
(raise-type-error
'count "proper list"
(ormap (lambda (x) (and (not (list? x)) x)) (cons l ls))))
(check-filter-arguments 'count f l ls)
(if (pair? ls)
(let ([len (length l)])
(if (andmap (lambda (l) (= len (length l))) ls)
@ -283,15 +289,15 @@
c
(loop (cdr l) (map cdr ls)
(if (apply f (car l) (map car ls)) (add1 c) c))))
(error 'count "all lists must have same size")))
(raise-arguments-error 'count "all lists must have same size")))
(let loop ([l l] [c 0])
(if (null? l) c (loop (cdr l) (if (f (car l)) (add1 c) c))))))
;; Originally from srfi-1 -- shares common tail with the input when possible
;; (define (partition f l)
;; (unless (and (procedure? f) (procedure-arity-includes? f 1))
;; (raise-type-error 'partition "procedure (arity 1)" f))
;; (unless (list? l) (raise-type-error 'partition "proper list" l))
;; (raise-argument-error 'partition "procedure (arity 1)" f))
;; (unless (list? l) (raise-argument-error 'partition "proper list" l))
;; (let loop ([l l])
;; (if (null? l)
;; (values null null)
@ -304,8 +310,8 @@
;; But that one is slower than this, probably due to value packaging
(define (partition pred l)
(unless (and (procedure? pred) (procedure-arity-includes? pred 1))
(raise-type-error 'partition "procedure (arity 1)" 0 pred l))
(unless (list? l) (raise-type-error 'partition "proper list" 1 pred l))
(raise-argument-error 'partition "(any/c . -> . any/c)" 0 pred l))
(unless (list? l) (raise-argument-error 'partition "list?" 1 pred l))
(let loop ([l l] [i '()] [o '()])
(if (null? l)
(values (reverse i) (reverse o))
@ -322,9 +328,9 @@
(define (filter-not f list)
(unless (and (procedure? f)
(procedure-arity-includes? f 1))
(raise-type-error 'filter-not "procedure (arity 1)" 0 f list))
(raise-argument-error 'filter-not "(any/c . -> . any/c)" 0 f list))
(unless (list? list)
(raise-type-error 'filter-not "proper list" 1 f list))
(raise-argument-error 'filter-not "list?" 1 f list))
;; accumulating the result and reversing it is currently slightly
;; faster than a plain loop
(let loop ([l list] [result null])
@ -339,13 +345,13 @@
(define (mk-min cmp name f xs)
(unless (and (procedure? f)
(procedure-arity-includes? f 1))
(raise-type-error name "procedure (arity 1)" 0 f xs))
(raise-argument-error name "(any/c . -> . real?)" 0 f xs))
(unless (and (list? xs)
(pair? xs))
(raise-type-error name "non-empty list" 1 f xs))
(raise-argument-error name "(and/c list? (not/c empty?))" 1 f xs))
(let ([init-min-var (f (car xs))])
(unless (real? init-min-var)
(raise-type-error name "procedure that returns real numbers" 0 f xs))
(raise-result-error name "real?" init-min-var))
(let loop ([min (car xs)]
[min-var init-min-var]
[xs (cdr xs)])
@ -354,7 +360,7 @@
[else
(let ([new-min (f (car xs))])
(unless (real? new-min)
(raise-type-error name "procedure that returns real numbers" 0 f xs))
(raise-result-error name "real?" new-min))
(cond
[(cmp new-min min-var)
(loop (car xs) new-min (cdr xs))]

19
collects/racket/math.rkt
View File

@ -11,44 +11,43 @@
order-of-magnitude)
(define (sqr z)
(unless (number? z) (raise-type-error 'sqr "number" z))
(unless (number? z) (raise-argument-error 'sqr "number?" z))
(* z z))
(define pi (atan 0 -1))
;; sgn function
(define (sgn x)
(unless (real? x) (raise-type-error 'sgn "real number" x))
(unless (real? x) (raise-argument-error 'sgn "real?" x))
(if (exact? x)
(cond [(< x 0) -1] [(> x 0) 1] [else 0])
(cond [(< x 0.0) -1.0] [(> x 0.0) 1.0] [else 0.0])))
;; complex conjugate
(define (conjugate z)
(unless (number? z) (raise-type-error 'conjugate "number" z))
(unless (number? z) (raise-argument-error 'conjugate "number?" z))
(make-rectangular (real-part z) (- (imag-part z))))
;; real hyperbolic functions
(define (sinh x)
(unless (number? x) (raise-type-error 'sinh "number" x))
(unless (number? x) (raise-argument-error 'sinh "number?" x))
(/ (- (exp x) (exp (- x))) 2.0))
(define (cosh x)
(unless (number? x) (raise-type-error 'cosh "number" x))
(unless (number? x) (raise-argument-error 'cosh "number?" x))
(/ (+ (exp x) (exp (- x))) 2.0))
(define (tanh x)
(unless (number? x) (raise-type-error 'tanh "number" x))
(unless (number? x) (raise-argument-error 'tanh "number?" x))
(/ (sinh x) (cosh x)))
(define order-of-magnitude
(let* ([exact-log (λ (x) (inexact->exact (log x)))]
[inverse-exact-log10 (/ (exact-log 10))])
(λ (r)
(unless (and (real? r) (positive? r))
(raise-type-error 'order-of-magnitude "positive real number" r))
(when (= r +inf.0)
(raise-type-error 'order-of-magnitude "non-infinite" r))
(unless (and (real? r) (positive? r)
(not (= r +inf.0)))
(raise-argument-error 'order-of-magnitude "(and/c (>/c 0.0) (not/c +inf.0))" r))
(let* ([q (inexact->exact r)]
[m
(floor

10
collects/racket/package.rkt
View File

@ -435,7 +435,10 @@
(let ([v (and (identifier? id)
(syntax-local-value id (lambda () #f)))])
(unless (package? v)
(raise-type-error 'package-exported-identifiers "identifier bound to a package" id))
(if (identifier? id)
(raise-arguments-error 'package-exported-identifiers "identifier is not bound to a package"
"identifier" id)
(raise-argument-error 'package-exported-identifiers "identifier?" id)))
(let ([introduce (syntax-local-make-delta-introducer
(syntax-local-introduce id))])
(map (lambda (i)
@ -448,5 +451,8 @@
(let ([v (and (identifier? id)
(syntax-local-value id (lambda () #f)))])
(unless (package? v)
(raise-type-error 'package-exported-identifiers "identifier bound to a package" id))
(if (identifier? id)
(raise-arguments-error 'package-original-identifiers "identifier is not bound to a package"
"identifier" id)
(raise-argument-error 'package-original-identifiers "identifier?" id)))
(map cdr ((package-exports v)))))

34
collects/racket/path.rkt
View File

@ -13,7 +13,7 @@
(define (simple-form-path p)
(unless (path-string? p)
(raise-type-error 'simple-form-path "path or string" p))
(raise-argument-error 'simple-form-path "path-string?" p))
(simplify-path (path->complete-path p)))
;; Note that normalize-path does not normalize the case
@ -34,14 +34,14 @@
resolved)
resolved)])
(if (member path seen-paths)
(error 'normalize-path "circular reference at ~s" path)
(error 'normalize-path "circular reference found\n path: ~a" path)
(let ([spath
;; Use simplify-path to get rid of ..s, which can
;; allow the path to grow indefinitely in a cycle.
;; An exception must mean a cycle of links.
(with-handlers ([exn:fail:filesystem?
(lambda (x)
(error 'normalize-path "circular reference at ~s" path))])
(error 'normalize-path "circular reference found\n path: ~a" path))])
(simplify-path path))])
(loop spath (cons path seen-paths))))))))))]
[resolve
@ -53,13 +53,13 @@
(case-lambda
[(orig-path) (do-normalize-path orig-path (current-directory))]
[(orig-path wrt)
(unless (complete-path? wrt)
(raise-type-error 'normalize-path "complete path" wrt))
(unless (and (path-string? wrt) (complete-path? wrt))
(raise-argument-error 'normalize-path "(and/c path-string? complete-path?)" wrt))
(do-normalize-path orig-path wrt)])]
[error-not-a-dir
(lambda (path)
(error 'normalize-path
"~s (within the input path) is not a directory or does not exist"
"element within the input path is not a directory or does not exist\n element: ~a"
path))]
[do-normalize-path
(lambda (orig-path wrt)
@ -75,7 +75,7 @@
(cond
[(not prev)
(error 'normalize-path
"root has no parent directory: ~s"
"root has no parent directory\n root path: ~a"
orig-path)]
[else
(let ([prev
@ -113,14 +113,14 @@
;; Argument must be in simple form
(define (do-explode-path who orig-path simple?)
(let loop ([path orig-path][rest '()])
(let loop ([path orig-path] [rest '()])
(let-values ([(base name dir?) (split-path path)])
(when simple?
(when (or (and base (not (path-for-some-system? base)))
(not (path-for-some-system? name)))
(raise-type-error who
"path (for ay platform) in simple form (absolute, complete, and with no same- or up-directory indicators)"
orig-path)))
(raise-argument-error who
"(and/c path-for-some-system? simple-form?)"
orig-path)))
(if (path-for-some-system? base)
(loop base (cons name rest))
(cons name rest)))))
@ -128,7 +128,7 @@
(define (explode-path orig-path)
(unless (or (path-string? orig-path)
(path-for-some-system? orig-path))
(raise-type-error 'explode-path "path (for any platform) or string" orig-path))
(raise-argument-error 'explode-path "(or/c path-string? path-for-some-system?)" orig-path))
(do-explode-path 'explode-path orig-path #f))
;; Arguments must be in simple form
@ -156,7 +156,7 @@
(define (file-name who name)
(unless (or (path-string? name)
(path-for-some-system? name))
(raise-type-error who "path (for any platform) or string" name))
(raise-argument-error who "(or/c path-string? path-for-some-system?)" name))
(let-values ([(base file dir?) (split-path name)])
(and (not dir?) (path-for-some-system? file) file)))
@ -166,7 +166,7 @@
(define (path-only name)
(unless (or (path-string? name)
(path-for-some-system? name))
(raise-type-error 'path-only "path (for any platform) or string" name))
(raise-argument-error 'path-only "(or/c path-string? path-for-some-system?)" name))
(let-values ([(base file dir?) (split-path name)])
(cond [dir? (if (string? name) (string->path name) name)]
[(path-for-some-system? base) base]
@ -181,15 +181,15 @@
(define (some-system-path->string path)
(unless (path-for-some-system? path)
(raise-type-error 'some-system-path->string "path (for any platform)" path))
(raise-argument-error 'some-system-path->string "path-for-some-system?" path))
(bytes->string/utf-8 (path->bytes path)))
(define (string->some-system-path path kind)
(unless (string? path)
(raise-type-error 'string->some-system-path "string" path))
(raise-argument-error 'string->some-system-path "string?" path))
(unless (or (eq? kind 'unix)
(eq? kind 'windows))
(raise-type-error 'string->some-system-path "'unix or 'windows" kind))
(raise-argument-error 'string->some-system-path "(or/c 'unix 'windows)" kind))
(bytes->path (string->bytes/utf-8 path) kind))
(define (path-element? path)

19
collects/racket/place.rkt
View File

@ -85,24 +85,25 @@
;; unfortunately, but we want these checks before we start making
;; stream-pumping threads, etc.
(unless (or (module-path? module-path) (path? module-path))
(raise-type-error who "module-path or path" module-path))
(raise-argument-error who "(or/c module-path? path?)" module-path))
(unless (symbol? function)
(raise-type-error who "symbol" function))
(raise-argument-error who "symbol?" function))
(unless (or (not in) (input-port? in))
(raise-type-error who "input-port or #f" in))
(raise-argument-error who "(or/c input-port? #f)" in))
(unless (or (not out) (output-port? out))
(raise-type-error who "output-port or #f" out))
(raise-argument-error who "(or/c output-port? #f)" out))
(unless (or (not err) (output-port? err) (eq? err 'stdout))
(raise-type-error who "output-port, #f, or 'stdout" err))
(raise-argument-error who "(or/c output-port? #f 'stdout)" err))
(when (and (pair? module-path) (eq? (car module-path) 'quote)
(not (module-predefined? module-path)))
(raise-mismatch-error who "not a filesystem or predefined module-path: " module-path))
(raise-arguments-error who "not a filesystem or predefined module path"
"module path" module-path))
(when (and (input-port? in) (port-closed? in))
(raise-mismatch-error who "input port is closed: " in))
(raise-arguments-error who "input port is closed" "port" in))
(when (and (output-port? out) (port-closed? out))
(raise-mismatch-error who "output port is closed: " out))
(raise-arguments-error who "output port is closed" "port" out))
(when (and (output-port? err) (port-closed? err))
(raise-mismatch-error who "error port is closed: " err))
(raise-arguments-error who "error port is closed" "port" err))
(cond
[(pl-place-enabled?)
(define-values (p pin pout perr)

16
collects/racket/port.rkt
View File

@ -22,7 +22,7 @@
call-with-input-bytes)
(define (port->string-port who p)
(unless (input-port? p) (raise-type-error who "input-port" p))
(unless (input-port? p) (raise-argument-error who "input-port?" p))
(let ([s (open-output-string)]) (copy-port p s) s))
(define (port->string [p (current-input-port)])
@ -39,19 +39,19 @@
(define (port->list [r read] [p (current-input-port)])
(unless (input-port? p)
(raise-type-error 'port->list "input-port" p))
(raise-argument-error 'port->list "input-port?" p))
(unless (and (procedure? r) (procedure-arity-includes? r 1))
(raise-type-error 'port->list "procedure (arity 1)" r))
(raise-argument-error 'port->list "(procedure-arity-includes/c 1)" r))
(for/list ([v (in-port r p)]) v))
(define (display-lines l [p (current-output-port)] #:separator [newline #"\n"])
(unless (list? l) (raise-type-error 'display-lines "list" l))
(unless (output-port? p) (raise-type-error 'display-lines "output-port" p))
(unless (list? l) (raise-argument-error 'display-lines "list?" l))
(unless (output-port? p) (raise-argument-error 'display-lines "output-port?" p))
(do-lines->port l p newline))
(define (with-output-to-x who n proc)
(unless (and (procedure? proc) (procedure-arity-includes? proc n))
(raise-type-error who (format "procedure (arity ~a)" n) proc))
(raise-argument-error who (if (zero? n) "(-> any)" "(output-port? . -> . any)") proc))
(let ([s (open-output-bytes)])
;; Use `dup-output-port' to hide string-port-ness of s:
(if (zero? n)
@ -74,9 +74,9 @@
(define (with-input-from-x who n b? str proc)
(unless (if b? (bytes? str) (string? str))
(raise-type-error who (if b? "byte string" "string") 0 str proc))
(raise-argument-error who (if b? "bytes?" "string?") 0 str proc))
(unless (and (procedure? proc) (procedure-arity-includes? proc n))
(raise-type-error who (format "procedure (arity ~a)" n) 1 str proc))
(raise-argument-error who (if (zero? n) "(-> any)" "(input-port? . -> . any)") 1 str proc))
(let ([s (if b? (open-input-bytes str) (open-input-string str))])
(if (zero? n)
(parameterize ([current-input-port s])

62
collects/racket/pretty.rkt
View File

@ -45,25 +45,27 @@
(define pretty-print-extend-style-table
(lambda (table symbols like-symbols)
(let ([terr (lambda (kind which)
(raise-type-error
(raise-argument-error
'pretty-print-extend-style-table
kind
which
table symbols like-symbols))])
(unless (or (not table) (pretty-print-style-table? table))
(terr "pretty-print style table or #f" 0))
(terr "(or/c pretty-print-style-table? #f)" 0))
(unless (and (list? symbols)
(andmap symbol? symbols))
(terr "list of symbols" 1))
(terr "(listof symbol?)" 1))
(unless (and (list? like-symbols)
(andmap symbol? like-symbols))
(terr "list of symbols" 1))
(terr "(listof symbol?)" 1))
(unless (= (length symbols) (length like-symbols))
(raise-mismatch-error
(raise-arguments-error
'pretty-print-extend-style-table
(format "length of first list (~a) doesn't match the length of the second list (~a): "
(length symbols) (length like-symbols))
like-symbols)))
"length of first list doesn't match the length of the second list"
"first list length" (length symbols)
"second list length" (length like-symbols)
"first list" symbols
"second list" like-symbols)))
(let ([ht (if table (pretty-print-style-table-hash table) (make-hasheq))]
[new-ht (make-hasheq)])
(hash-for-each
@ -86,9 +88,9 @@
(pretty-print-extend-style-table #f null null)
(lambda (s)
(unless (pretty-print-style-table? s)
(raise-type-error
(raise-argument-error
'pretty-print-current-style-table
"pretty-print style table"
"pretty-print-style-table?"
s))
s)))
@ -108,9 +110,9 @@
(lambda (x)
(unless (or (eq? x 'infinity)
(integer? x))
(raise-type-error
(raise-argument-error
'pretty-print-columns
"integer or 'infinity"
"(or/c integer? 'infinity)"
x))
x)))
@ -118,9 +120,9 @@
(make-parameter #f
(lambda (x)
(unless (or (not x) (number? x))
(raise-type-error
(raise-argument-error
'pretty-print-depth
"number or #f"
"(or/c number? #f)"
x))
x)))
@ -132,9 +134,9 @@
(make-parameter (lambda (x display? port) #f)
(lambda (x)
(unless (can-accept-n? 3 x)
(raise-type-error
(raise-argument-error
'pretty-print-size-hook
"procedure of 3 arguments"
"(any/c any/c any/c . -> . any/c)"
x))
x)))
@ -142,9 +144,9 @@
(make-parameter void
(lambda (x)
(unless (can-accept-n? 3 x)
(raise-type-error
(raise-argument-error
'pretty-print-print-hook
"procedure of 3 arguments"
"(any/c any/c any/c . -> . any/c)"
x))
x)))
@ -156,9 +158,9 @@
0)
(lambda (x)
(unless (can-accept-n? 4 x)
(raise-type-error
(raise-argument-error
'pretty-print-print-line
"procedure of 4 arguments"
"(procedure-arity-includes/c 4)"
x))
x)))
@ -166,9 +168,9 @@
(make-parameter void
(lambda (x)
(unless (can-accept-n? 2 x)
(raise-type-error
(raise-argument-error
'pretty-print-pre-print-hook
"procedure of 2 arguments"
"(any/c any/c . -> . any/c)"
x))
x)))
@ -176,9 +178,9 @@
(make-parameter void
(lambda (x)
(unless (can-accept-n? 2 x)
(raise-type-error
(raise-argument-error
'pretty-print-post-print-hook
"procedure of 2 arguments"
"(any/c any/c . -> . any/c)"
x))
x)))
@ -189,16 +191,16 @@
(make-parameter (λ (x) #f)
(λ (f)
(unless (can-accept-n? 1 f)
(raise-type-error
(raise-argument-error
'pretty-print-remap-stylable
"procedure of 1 argument"
"(symbol? . -> . (or/c symbol? #f))"
f))
(λ (x)
(let ([res (f x)])
(unless (or (not res) (symbol? res))
(raise-type-error
(raise-result-error
'pretty-print-remap-stylable
"result of parameter function to be a symbol or #f"
"(or/c symbol? #f)"
res))
res)))))
@ -208,10 +210,10 @@
(case-lambda
[(obj port qq-depth)
(unless (output-port? port)
(raise-type-error name "output port" port))
(raise-argument-error name "output-port?" port))
(unless (or (equal? qq-depth 0)
(equal? qq-depth 1))
(raise-type-error name "0 or 1" qq-depth))
(raise-argument-error name "(or/c 0 1)" qq-depth))
(let ([width (pretty-print-columns)]
[size-hook (pretty-print-size-hook)]
[print-hook (pretty-print-print-hook)]

10
collects/racket/promise.rkt
View File

@ -102,7 +102,7 @@
(define (delay/thread thunk group)
(unless (or (not group)
(thread-group? group))
(raise-type-error 'delay/thread "thread group" group))
(raise-argument-error 'delay/thread "(or/c thread-group? #f)" group))
(let ()
(define (run)
(call-with-exception-handler
@ -137,13 +137,13 @@
(provide (rename-out [delay/idle* delay/idle]))
(define (delay/idle thunk wait-for work-while tick use*)
(unless (evt? wait-for)
(raise-type-error 'delay/idle "evt" wait-for))
(raise-argument-error 'delay/idle "evt?" wait-for))
(unless (evt? work-while)
(raise-type-error 'delay/idle "evt" work-while))
(raise-argument-error 'delay/idle "evt?" work-while))
(unless (and (real? tick) (not (negative? tick)))
(raise-type-error 'delay/idle "nonnegative real" tick))
(raise-argument-error 'delay/idle "(>=/c 0.0)" tick))
(unless (real? use*)
(raise-type-error 'delay/idle "real" use*))
(raise-argument-error 'delay/idle "real?" use*))
(let ()
(define use (cond [(use* . <= . 0) 0] [(use* . >= . 1) 1] [else use*]))
(define work-time (* tick use))

8
collects/racket/provide-transform.rkt
View File

@ -16,14 +16,14 @@
(define-struct* export (local-id out-sym mode protect? orig-stx)
#:guard (lambda (i s mode protect? stx info)
(unless (identifier? i)
(raise-type-error 'make-export "identifier" i))
(raise-argument-error 'make-export "identifier?" i))
(unless (symbol? s)
(raise-type-error 'make-export "symbol" s))
(raise-argument-error 'make-export "symbol?" s))
(unless (or (not mode)
(exact-integer? mode))
(raise-type-error 'make-export "exact integer or #f" mode))
(raise-argument-error 'make-export "(or/c exact-integer? #f)" mode))
(unless (syntax? stx)
(raise-type-error 'make-export "syntax" stx))
(raise-argument-error 'make-export "syntax?" stx))
(values i s mode (and protect? #t) stx)))
(define-values (prop:provide-pre-transformer provide-pre-transformer? provide-pre-transformer-get-proc)

34
collects/racket/require-transform.rkt
View File

@ -21,38 +21,38 @@
(define-struct* import (local-id src-sym src-mod-path mode req-mode orig-mode orig-stx)
#:guard (lambda (i s path mode req-mode orig-mode stx info)
(unless (identifier? i)
(raise-type-error 'make-import "identifier" i))
(raise-argument-error 'make-import "identifier?" i))
(unless (symbol? s)
(raise-type-error 'make-import "symbol" s))
(raise-argument-error 'make-import "symbol?" s))
(unless (module-path? path)
(raise-type-error 'make-import "module-path" path))
(raise-argument-error 'make-import "module-path?" path))
(unless (or (not mode)
(exact-integer? mode))
(raise-type-error 'make-import "exact integer or #f" mode))
(raise-argument-error 'make-import "(or/c exact-integer? #f)" mode))
(unless (or (not req-mode)
(exact-integer? req-mode))
(raise-type-error 'make-import "'exact integer or #f" req-mode))
(raise-argument-error 'make-import "(or/c exact-integer? #f)" req-mode))
(unless (or (not orig-mode)
(exact-integer? orig-mode))
(raise-type-error 'make-import "'exact integer or #f" orig-mode))
(raise-argument-error 'make-import "(or/c exact-integer? #f)" orig-mode))
(unless (equal? mode (and req-mode orig-mode (+ req-mode orig-mode)))
(raise-mismatch-error 'make-import
(format
"orig mode: ~a and require mode: ~a not consistent with mode: "
orig-mode req-mode)
mode))
(raise-arguments-error 'make-import
"original mode and require mode not consistent with mode"
"original mode" orig-mode
"require mode" req-mode
"mode" mode))
(unless (syntax? stx)
(raise-type-error 'make-import "syntax" stx))
(raise-argument-error 'make-import "syntax?" stx))
(values i s path mode req-mode orig-mode stx)))
(define-struct* import-source (mod-path-stx mode)
#:guard (lambda (path mode info)
(unless (and (syntax? path)
(module-path? (syntax->datum path)))
(raise-type-error 'make-import-source "syntax module-path" path))
(raise-argument-error 'make-import-source "(and/c syntax? (lambda (s) (module-path? (syntax->datum s))))" path))
(unless (or (not mode)
(exact-integer? mode))
(raise-type-error 'make-import-source "exact integer or #f" mode))
(raise-argument-error 'make-import-source "(or/c exact-integer? #f)" mode))
(values path mode)))
(define-values (prop:require-transformer require-transformer? require-transformer-get-proc)
@ -78,9 +78,9 @@
(lambda (v)
(unless (or (not v)
(module-path-index? v))
(raise-type-error 'current-require-module-path
"#f or module path index"
v))
(raise-argument-error 'current-require-module-path
"(or/c module-path-index? #f)"
v))
v)))
;; a simplified version of `collapse-module-path-index', where

4
collects/racket/sandbox.rkt
View File

@ -205,9 +205,9 @@
(if (or (security-guard? x)
(and (procedure? x) (procedure-arity-includes? x 0)))
x
(raise-type-error
(raise-argument-error
'sandbox-security-guard
"security-guard or a security-guard translator procedure" x)))))
"(or/c security-guard? (-> security-guard?))" x)))))
;; this is never really used (see where it's used in the evaluator)
(define (default-sandbox-exit-handler _) (error 'exit "sandbox exits"))

37
collects/racket/sequence.rkt
View File

@ -33,29 +33,29 @@
(for/list ([v s]) v))
(define (sequence-length s)
(unless (sequence? s) (raise-type-error 'sequence-length "sequence" s))
(unless (sequence? s) (raise-argument-error 'sequence-length "sequence?" s))
(for/fold ([c 0]) ([i (in-values*-sequence s)])
(add1 c)))
(define (sequence-ref s i)
(unless (sequence? s) (raise-type-error 'sequence-ref "sequence" s))
(unless (sequence? s) (raise-argument-error 'sequence-ref "sequence?" s))
(unless (exact-nonnegative-integer? i)
(raise-type-error 'sequence-ref "nonnegative exact integer" i))
(raise-argument-error 'sequence-ref "exact-nonnegative-integer?" i))
(let ([v (for/fold ([c #f]) ([v (in-values-sequence s)]
[i (in-range (add1 i))])
v)])
(if (list? v)
(apply values v)
(raise-mismatch-error
(raise-arguments-error
'sequence-ref
(format "sequence ended before element ~e: "
(add1 i))
s))))
"sequence ended before index"
"index" (add1 i)
"sequence" s))))
(define (sequence-tail seq i)
(unless (sequence? seq) (raise-type-error 'sequence-tail "sequence" seq))
(unless (sequence? seq) (raise-argument-error 'sequence-tail "sequence?" seq))
(unless (exact-nonnegative-integer? i)
(raise-type-error 'sequence-tail "nonnegative exact integer" i))
(raise-argument-error 'sequence-tail "exact-nonnegative-integer?" i))
(cond
[(zero? i) seq]
[(stream? seq) (stream-tail seq i)]
@ -79,12 +79,11 @@
(let-values ([(vals next) (next)])
(if vals
(loop next (sub1 n))
(raise-mismatch-error
(raise-arguments-error
'sequence-ref
(format "sequence ended before ~e element~a: "
i
(if (= i 1) "" "s"))
seq)))]))))]))
"sequence ended before index"
"index" i
"sequence" seq)))]))))]))
(define (sequence-append . l)
(if (null? l)
@ -94,8 +93,8 @@
(apply in-sequences l))))
(define (sequence-map f s)
(unless (procedure? f) (raise-type-error 'sequence-map "procedure" f))
(unless (sequence? s) (raise-type-error 'sequence-map "sequence" s))
(unless (procedure? f) (raise-argument-error 'sequence-map "procedure?" f))
(unless (sequence? s) (raise-argument-error 'sequence-map "sequence?" s))
(if (stream? s)
(stream-map f s)
(make-do-sequence
@ -112,8 +111,8 @@
(define (sequence-filter f s)
(unless (procedure? f) (raise-type-error 'sequence-filter "procedure" f))
(unless (sequence? s) (raise-type-error 'sequence-filter "sequence" s))
(unless (procedure? f) (raise-argument-error 'sequence-filter "procedure?" f))
(unless (sequence? s) (raise-argument-error 'sequence-filter "sequence?" s))
(if (stream? s)
(stream-filter f s)
(make-do-sequence
@ -137,7 +136,7 @@
(loop next))))))))
(define (sequence-add-between s e)
(unless (sequence? s) (raise-type-error 'sequence-add-between "sequence" s))
(unless (sequence? s) (raise-argument-error 'sequence-add-between "sequence?" s))
(if (stream? s)
(stream-add-between s e)
(make-do-sequence

129
collects/racket/set.rkt
View File

@ -92,7 +92,7 @@
(define (chaperone-set s elem-chaperone)
(when (or (set-eq? s)
(set-eqv? s))
(raise-type-error 'chaperone-set "equal-based set" s))
(raise-argument-error 'chaperone-set "(and/c set? set-equal?)" s))
(chaperone-struct s
set-ht
(let ([cached-ht #f])
@ -116,37 +116,45 @@
(make-set (make-immutable-hasheqv (map (lambda (k) (cons k #t)) elems))))
(define (set-eq? set)
(unless (set? set) (raise-type-error 'set-eq? "set" 0 set))
(unless (set? set) (raise-argument-error 'set-eq? "set?" 0 set))
(hash-eq? (set-ht set)))
(define (set-eqv? set)
(unless (set? set) (raise-type-error 'set-eqv? "set" 0 set))
(unless (set? set) (raise-argument-error 'set-eqv? "set?" 0 set))
(hash-eqv? (set-ht set)))
(define (set-equal? set)
(unless (set? set) (raise-type-error 'set-equal? "set" 0 set))
(unless (set? set) (raise-argument-error 'set-equal? "set?" 0 set))
(let* ([ht (set-ht set)])
(not (or (hash-eq? ht)
(hash-eqv? ht)))))
(define (set-empty? set)
(unless (set? set) (raise-type-error 'set-empty? "set" 0 set))
(unless (set? set) (raise-argument-error 'set-empty? "set?" 0 set))
(zero? (hash-count (set-ht set))))
(define (set-count set)
(unless (set? set) (raise-type-error 'set-count "set" 0 set))
(unless (set? set) (raise-argument-error 'set-count "set?" 0 set))
(hash-count (set-ht set)))
(define (set-member? set v)
(unless (set? set) (raise-type-error 'set-member? "set" 0 set v))
(unless (set? set) (raise-argument-error 'set-member? "set?" 0 set v))
(hash-ref (set-ht set) v #f))
(define (set-add set v)
(unless (set? set) (raise-type-error 'set-add "set" 0 set v))
(unless (set? set) (raise-argument-error 'set-add "set?" 0 set v))
(make-set (hash-set (set-ht set) v #t)))
(define (set-remove set v)
(unless (set? set) (raise-type-error 'set-remove "set" 0 set v))
(unless (set? set) (raise-argument-error 'set-remove "set?" 0 set v))
(make-set (hash-remove (set-ht set) v)))
(define (check-same-equiv who set set2 ht ht2)
(unless (and (eq? (hash-eq? ht) (hash-eq? ht2))
(eq? (hash-eqv? ht) (hash-eqv? ht2)))
(raise-arguments-error who
"second set's equivalence predicate is not the same as the first set's"
"first set" set
"second set" set2)))
(define set-union
(case-lambda
;; No 0 argument set exists because its not clear what type of set
@ -156,17 +164,14 @@
;; (set-union (set-eqv))
;; [() (set)]
[(set)
(unless (set? set) (raise-type-error 'set-union "set" 0 set))
(unless (set? set) (raise-argument-error 'set-union "set?" 0 set))
set]
[(set set2)
(unless (set? set) (raise-type-error 'set-union "set" 0 set set2))
(unless (set? set2) (raise-type-error 'set-union "set" 1 set set2))
(unless (set? set) (raise-argument-error 'set-union "set?" 0 set set2))
(unless (set? set2) (raise-argument-error 'set-union "set?" 1 set set2))
(let ([ht (set-ht set)]
[ht2 (set-ht set2)])
(unless (and (eq? (hash-eq? ht) (hash-eq? ht2))
(eq? (hash-eqv? ht) (hash-eqv? ht2)))
(raise-mismatch-error 'set-union "set's equivalence predicate is not the same as the first set: "
set2))
(check-same-equiv 'set-union set set2 ht ht2)
(let-values ([(ht ht2)
(if ((hash-count ht2) . > . (hash-count ht))
(values ht2 ht)
@ -177,7 +182,7 @@
[(set . sets)
(for ([s (in-list (cons set sets))]
[i (in-naturals)])
(unless (set? s) (apply raise-type-error 'set-union "set" i (cons set sets))))
(unless (set? s) (apply raise-argument-error 'set-union "set?" i (cons set sets))))
(for/fold ([set set]) ([set2 (in-list sets)])
(set-union set set2))]))
@ -190,17 +195,14 @@
(define set-intersect
(case-lambda
[(set)
(unless (set? set) (raise-type-error 'set-intersect "set" 0 set))
(unless (set? set) (raise-argument-error 'set-intersect "set?" 0 set))
set]
[(set set2)
(unless (set? set) (raise-type-error 'set-intersect "set" 0 set set2))
(unless (set? set2) (raise-type-error 'set-intersect "set" 1 set set2))
(unless (set? set) (raise-argument-error 'set-intersect "set?" 0 set set2))
(unless (set? set2) (raise-argument-error 'set-intersect "set?" 1 set set2))
(let ([ht1 (set-ht set)]
[ht2 (set-ht set2)])
(unless (and (eq? (hash-eq? ht1) (hash-eq? ht2))
(eq? (hash-eqv? ht1) (hash-eqv? ht2)))
(raise-mismatch-error 'set-union "set's equivalence predicate is not the same as the first set: "
set2))
(check-same-equiv 'set-intersect set set2 ht1 ht2)
(let-values ([(ht1 ht2) (if ((hash-count ht1) . < . (hash-count ht2))
(values ht1 ht2)
(values ht2 ht1))])
@ -212,24 +214,21 @@
[(set . sets)
(for ([s (in-list (cons set sets))]
[i (in-naturals)])
(unless (set? s) (apply raise-type-error 'set-intersect "set" i (cons set sets))))
(unless (set? s) (apply raise-argument-error 'set-intersect "set?" i (cons set sets))))
(for/fold ([set set]) ([set2 (in-list sets)])
(set-intersect set set2))]))
(define set-subtract
(case-lambda
[(set)
(unless (set? set) (raise-type-error 'set-subtract "set" 0 set))
(unless (set? set) (raise-argument-error 'set-subtract "set?" 0 set))
set]
[(set set2)
(unless (set? set) (raise-type-error 'set-subtract "set" 0 set set2))
(unless (set? set2) (raise-type-error 'set-subtract "set" 1 set set2))
(unless (set? set) (raise-argument-error 'set-subtract "set?" 0 set set2))
(unless (set? set2) (raise-argument-error 'set-subtract "set?" 1 set set2))
(let ([ht1 (set-ht set)]
[ht2 (set-ht set2)])
(unless (and (eq? (hash-eq? ht1) (hash-eq? ht2))
(eq? (hash-eqv? ht1) (hash-eqv? ht2)))
(raise-mismatch-error 'set-union "set's equivalence predicate is not the same as the first set: "
set2))
(check-same-equiv 'set-subtract set set2 ht1 ht2)
(if ((* 2 (hash-count ht1)) . < . (hash-count ht2))
;; Add elements from ht1 that are not in ht2:
(make-set
@ -244,20 +243,16 @@
[(set . sets)
(for ([s (in-list (cons set sets))]
[i (in-naturals)])
(unless (set? s) (apply raise-type-error 'set-subtract "set" i (cons s sets))))
(unless (set? s) (apply raise-argument-error 'set-subtract "set?" i (cons s sets))))
(for/fold ([set set]) ([set2 (in-list sets)])
(set-subtract set set2))]))
(define (subset* who set2 set1 proper?)
(unless (set? set2) (raise-type-error who "set" 0 set2 set1))
(unless (set? set1) (raise-type-error who "set" 0 set2 set1))
(unless (set? set2) (raise-argument-error who "set?" 0 set2 set1))
(unless (set? set1) (raise-argument-error who "set?" 0 set2 set1))
(let ([ht1 (set-ht set1)]
[ht2 (set-ht set2)])
(unless (and (eq? (hash-eq? ht1) (hash-eq? ht2))
(eq? (hash-eqv? ht1) (hash-eqv? ht2)))
(raise-mismatch-error who
"second set's equivalence predicate is not the same as the first set: "
set2))
(check-same-equiv who set set2 ht1 ht2)
(and (for/and ([v (in-hash-keys ht2)])
(hash-ref ht1 v #f))
(if proper?
@ -271,23 +266,23 @@
(subset* 'proper-subset? one two #t))
(define (set-map set proc)
(unless (set? set) (raise-type-error 'set-map "set" 0 set proc))
(unless (set? set) (raise-argument-error 'set-map "set?" 0 set proc))
(unless (and (procedure? proc)
(procedure-arity-includes? proc 1))
(raise-type-error 'set-map "procedure (arity 1)" 1 set proc))
(raise-argument-error 'set-map "(any/c . -> . any/c)" 1 set proc))
(for/list ([v (in-set set)])
(proc v)))
(define (set-for-each set proc)
(unless (set? set) (raise-type-error 'set-for-each "set" 0 set proc))
(unless (set? set) (raise-argument-error 'set-for-each "set?" 0 set proc))
(unless (and (procedure? proc)
(procedure-arity-includes? proc 1))
(raise-type-error 'set-for-each "procedure (arity 1)" 1 set proc))
(raise-argument-error 'set-for-each "(any/c . -> . any/c)" 1 set proc))
(for ([v (in-set set)])
(proc v)))
(define (in-set set)
(unless (set? set) (raise-type-error 'in-set "set" 0 set))
(unless (set? set) (raise-argument-error 'in-set "set?" 0 set))
(in-hash-keys (set-ht set)))
(define-sequence-syntax *in-set
@ -348,22 +343,22 @@
(let ()
(define (set/c ctc #:cmp [cmp 'dont-care])
(unless (memq cmp '(dont-care equal eq eqv))
(raise-type-error 'set/c
"(or/c 'dont-care 'equal? 'eq? 'eqv)"
cmp))
(raise-argument-error 'set/c
"(or/c 'dont-care 'equal? 'eq? 'eqv)"
cmp))
(cond
[(flat-contract? ctc)
(flat-set/c ctc cmp (flat-contract-predicate ctc))]
[(chaperone-contract? ctc)
(if (memq cmp '(eq eqv))
(raise-type-error 'set/c
"flat contract"
ctc)
(raise-argument-error 'set/c
"flat-contract?"
ctc)
(make-set/c ctc cmp))]
[else
(raise-type-error 'set/c
"chaperone contract"
ctc)]))
(raise-argument-error 'set/c
"chaperone-contract?"
ctc)]))
set/c))
(define (set/c-name c)
@ -440,26 +435,22 @@
;; ----
(define (set=? one two)
(unless (set? one) (raise-type-error 'set=? "set" 0 one two))
(unless (set? two) (raise-type-error 'set=? "set" 1 one two))
(unless (set? one) (raise-argument-error 'set=? "set?" 0 one two))
(unless (set? two) (raise-argument-error 'set=? "set?" 1 one two))
;; Sets implement prop:equal+hash
(equal? one two))
(define set-symmetric-difference
(case-lambda
[(set)
(unless (set? set) (raise-type-error 'set-symmetric-difference "set" 0 set))
(unless (set? set) (raise-argument-error 'set-symmetric-difference "set?" 0 set))
set]
[(set set2)
(unless (set? set) (raise-type-error 'set-symmetric-difference "set" 0 set set2))
(unless (set? set2) (raise-type-error 'set-symmetric-difference "set" 1 set set2))
(unless (set? set) (raise-argument-error 'set-symmetric-difference "set?" 0 set set2))
(unless (set? set2) (raise-argument-error 'set-symmetric-difference "set?" 1 set set2))
(let ([ht1 (set-ht set)]
[ht2 (set-ht set2)])
(unless (and (eq? (hash-eq? ht1) (hash-eq? ht2))
(eq? (hash-eqv? ht1) (hash-eqv? ht2)))
(raise-mismatch-error 'set-symmetric-difference
"set's equivalence predicate is not the same as the first set: "
set2))
(check-same-equiv 'set-symmetric-difference set set2 ht1 ht2)
(let-values ([(big small)
(if (>= (hash-count ht1) (hash-count ht2))
(values ht1 ht2)
@ -472,19 +463,19 @@
[(set . sets)
(for ([s (in-list (cons set sets))]
[i (in-naturals)])
(unless (set? s) (apply raise-type-error 'set-symmetric-difference "set" i (cons s sets))))
(unless (set? s) (apply raise-argument-error 'set-symmetric-difference "set?" i (cons s sets))))
(for/fold ([set set]) ([set2 (in-list sets)])
(set-symmetric-difference set set2))]))
(define (set->list set)
(unless (set? set) (raise-type-error 'set->list "set" 0 set))
(unless (set? set) (raise-argument-error 'set->list "set?" 0 set))
(for/list ([elem (in-hash-keys (set-ht set))]) elem))
(define (list->set elems)
(unless (list? elems) (raise-type-error 'list->set "list" 0 elems))
(unless (list? elems) (raise-argument-error 'list->set "list?" 0 elems))
(apply set elems))
(define (list->seteq elems)
(unless (list? elems) (raise-type-error 'list->seteq "list" 0 elems))
(unless (list? elems) (raise-argument-error 'list->seteq "list?" 0 elems))
(apply seteq elems))
(define (list->seteqv elems)
(unless (list? elems) (raise-type-error 'list->seteqv "list" 0 elems))
(unless (list? elems) (raise-argument-error 'list->seteqv "list?" 0 elems))
(apply seteqv elems))

60
collects/racket/stream.rkt
View File

@ -59,48 +59,46 @@
(for/list ([v (in-stream s)]) v))
(define (stream-length s)
(unless (stream? s) (raise-type-error 'stream-length "stream" s))
(unless (stream? s) (raise-argument-error 'stream-length "stream?" s))
(let loop ([s s] [len 0])
(if (stream-empty? s)
len
(loop (stream-rest s) (add1 len)))))
(define (stream-ref st i)
(unless (stream? st) (raise-type-error 'stream-ref "stream" st))
(unless (stream? st) (raise-argument-error 'stream-ref "stream?" st))
(unless (exact-nonnegative-integer? i)
(raise-type-error 'stream-ref "nonnegative exact integer" i))
(raise-argument-error 'stream-ref "exact-nonnegative-integer?" i))
(let loop ([n i] [s st])
(cond
[(stream-empty? s)
(raise-mismatch-error 'stream-ref
(format "sequence ended before element ~e: "
(add1 i))
st)]
(raise-arguments-error 'stream-ref
"stream ended before index"
"index" i
"stream" st)]
[(zero? n)
(stream-first s)]
[else
(loop (sub1 n) (stream-rest s))])))
(define (stream-tail st i)
(unless (stream? st) (raise-type-error 'stream-tail "stream" st))
(unless (stream? st) (raise-argument-error 'stream-tail "stream?" st))
(unless (exact-nonnegative-integer? i)
(raise-type-error 'stream-tail "nonnegative exact integer" i))
(raise-argument-error 'stream-tail "exact-nonnegative-integer?" i))
(let loop ([n i] [s st])
(cond
[(zero? n) s]
[(stream-empty? s)
(raise-mismatch-error
'stream-tail
(format "sequence ended before ~e element~a: "
i
(if (= i 1) "" "s"))
st)]
(raise-arguments-error 'stream-tail
"stream ended before index"
"index" i
"stream" st)]
[else
(loop (sub1 n) (stream-rest s))])))
(define (stream-append . l)
(for ([s (in-list l)])
(unless (stream? s) (raise-type-error 'stream-append "stream" s)))
(unless (stream? s) (raise-argument-error 'stream-append "stream?" s)))
(streams-append l))
(define (streams-append l)
@ -113,8 +111,8 @@
(lambda () (streams-append (cons (stream-rest (car l)) (cdr l)))))]))
(define (stream-map f s)
(unless (procedure? f) (raise-type-error 'stream-map "procedure" f))
(unless (stream? s) (raise-type-error 'stream-map "stream" s))
(unless (procedure? f) (raise-argument-error 'stream-map "procedure?" f))
(unless (stream? s) (raise-argument-error 'stream-map "stream?" s))
(let loop ([s s])
(cond
[(stream-empty? s) empty-stream]
@ -122,33 +120,33 @@
(loop (stream-rest s)))])))
(define (stream-andmap f s)
(unless (procedure? f) (raise-type-error 'stream-andmap "procedure" f))
(unless (stream? s) (raise-type-error 'stream-andmap "stream" s))
(unless (procedure? f) (raise-argument-error 'stream-andmap "procedure?" f))
(unless (stream? s) (raise-argument-error 'stream-andmap "stream?" s))
(sequence-andmap f s))
(define (stream-ormap f s)
(unless (procedure? f) (raise-type-error 'stream-ormap "procedure" f))
(unless (stream? s) (raise-type-error 'stream-ormap "stream" s))
(unless (procedure? f) (raise-argument-error 'stream-ormap "procedure?" f))
(unless (stream? s) (raise-argument-error 'stream-ormap "stream?" s))
(sequence-ormap f s))
(define (stream-for-each f s)
(unless (procedure? f) (raise-type-error 'stream-for-each "procedure" f))
(unless (stream? s) (raise-type-error 'stream-for-each "stream" s))
(unless (procedure? f) (raise-argument-error 'stream-for-each "procedure?" f))
(unless (stream? s) (raise-argument-error 'stream-for-each "stream?" s))
(sequence-for-each f s))
(define (stream-fold f i s)
(unless (procedure? f) (raise-type-error 'stream-fold "procedure" f))
(unless (stream? s) (raise-type-error 'stream-fold "stream" s))
(unless (procedure? f) (raise-argument-error 'stream-fold "procedure?" f))
(unless (stream? s) (raise-argument-error 'stream-fold "stream?" s))
(sequence-fold f i s))
(define (stream-count f s)
(unless (procedure? f) (raise-type-error 'stream-count "procedure" f))
(unless (stream? s) (raise-type-error 'stream-count "stream" s))
(unless (procedure? f) (raise-argument-error 'stream-count "procedure?" f))
(unless (stream? s) (raise-argument-error 'stream-count "stream?" s))
(sequence-count f s))
(define (stream-filter f s)
(unless (procedure? f) (raise-type-error 'stream-filter "procedure" f))
(unless (stream? s) (raise-type-error 'stream-filter "stream" s))
(unless (procedure? f) (raise-argument-error 'stream-filter "procedure?" f))
(unless (stream? s) (raise-argument-error 'stream-filter "stream?" s))
(cond
[(stream-empty? s) empty-stream]
[else
@ -174,7 +172,7 @@
(define (stream-add-between s e)
(unless (stream? s)
(raise-type-error 'stream-add-between "stream" s))
(raise-argument-error 'stream-add-between "stream?" s))
(if (stream-empty? s)
empty-stream
(stream-cons

16
collects/racket/string.rkt
View File

@ -19,9 +19,9 @@
(define (string-join strs [sep " "])
(cond [(not (and (list? strs) (andmap string? strs)))
(raise-type-error 'string-join "list-of-strings" strs)]
(raise-argument-error 'string-join "(listof string?)" strs)]
[(not (string? sep))
(raise-type-error 'string-join "string" sep)]
(raise-argument-error 'string-join "string?" sep)]
[(null? strs) ""]
[(null? (cdr strs)) (car strs)]
[else (apply string-append (add-between strs sep))]))
@ -39,8 +39,8 @@
(hash-ref! (if +? t+ t) rx
(λ () (let* ([s (cond [(string? rx) (regexp-quote rx)]
[(regexp? rx) (object-name rx)]
[else (raise-type-error
who "string-or-regexp" rx)])]
[else (raise-argument-error
who "(or/c string? regexp?)" rx)])]
[s (if +? (string-append "(?:" s ")+") s)]
[^s (string-append "^" s)]
[s$ (string-append s "$")])
@ -50,7 +50,7 @@
;; returns start+end positions, #f when no trimming should happen
(define (internal-trim who str sep l? r? rxs)
(unless (string? str) (raise-type-error who "string" str))
(unless (string? str) (raise-argument-error who "string?" str))
(define l
(and l? (let ([p (regexp-match-positions (car rxs) str)])
(and p (let ([p (cdar p)]) (and (> p 0) p))))))
@ -94,15 +94,15 @@
(define replace-cache (make-weak-hasheq))
(define (string-replace str from to #:all? [all? #t])
(unless (string? str) (raise-type-error 'string-replace "string" str))
(unless (string? to) (raise-type-error 'string-replace "string" to))
(unless (string? str) (raise-argument-error 'string-replace "string?" str))
(unless (string? to) (raise-argument-error 'string-replace "string?" to))
(define from*
(if (regexp? from)
from
(hash-ref! replace-cache from
(λ() (if (string? from)
(regexp (regexp-quote from))
(raise-type-error 'string-replace "string" from))))))
(raise-argument-error 'string-replace "string?" from))))))
(define to* (regexp-replace-quote to))
(if all?
(regexp-replace* from* str to*)

2
collects/racket/stxparam-exptime.rkt
View File

@ -14,7 +14,7 @@
(set!-transformer-procedure v)
v)])
(unless (syntax-parameter? v)
(raise-type-error 'syntax-parameter-value "syntax parameter" v))
(raise-argument-error 'syntax-parameter-value "syntax-parameter?" v))
(let ([target (syntax-parameter-target v)])
(syntax-parameter-target-value target)))))

21
collects/racket/syntax.rkt
View File

@ -118,9 +118,10 @@
(define (check-restricted-format-string who fmt)
(unless (restricted-format-string? fmt)
(raise-type-error who
"format string using only ~a placeholders"
fmt)))
(raise-arguments-error who
(format "format string should have ~a placeholders"
fmt)
"format string" fmt)))
(define (->atom x err)
(cond [(string? x) x]
@ -129,9 +130,9 @@
[(keyword? x) (keyword->string x)]
[(number? x) x]
[(char? x) x]
[else (raise-type-error err
"string, symbol, identifier, keyword, character, or number"
x)]))
[else (raise-argument-error err
"(or/c string? symbol? identifier? keyword? char? number?)"
x)]))
;; == Error reporting ==
@ -140,14 +141,14 @@
(make-parameter #f
(lambda (new-value)
(unless (or (syntax? new-value) (eq? new-value #f))
(raise-type-error 'current-syntax-context
"syntax or #f"
new-value))
(raise-argument-error 'current-syntax-context
"(or/c syntax? #f)"
new-value))
new-value)))
(define (wrong-syntax stx #:extra [extras null] format-string . args)
(unless (or (eq? stx #f) (syntax? stx))
(raise-type-error 'wrong-syntax "syntax or #f" 0 (list* stx format-string args)))
(raise-argument-error 'wrong-syntax "(or/c syntax? #f)" 0 (list* stx format-string args)))
(let* ([ctx (current-syntax-context)]
[blame (and (syntax? ctx) (syntax-property ctx 'report-error-as))])
(raise-syntax-error (if (symbol? blame) blame #f)

2
collects/racket/tcp.rkt
View File

@ -24,5 +24,5 @@
(c:tcp-addresses socket port-numbers?)
(if (tcp-listener? socket)
(c:tcp-addresses socket port-numbers?)
(raise-type-error 'tcp-addresses "tcp-port or tcp-listener" socket)))])))
(raise-argument-error 'tcp-addresses "(or/c tcp-port? tcp-listener?)" socket)))])))

6
collects/racket/trace.rkt
View File

@ -66,9 +66,9 @@
(lambda (p)
(unless (and (procedure? p)
(procedure-arity-includes? p 1))
(raise-type-error 'current-trace-notify
"procedure (arity 1)"
p))
(raise-argument-error 'current-trace-notify
"(any/c . -> . any)"
p))
p)))
(define (as-trace-notify thunk)

12
collects/racket/trait.rkt
View File

@ -586,7 +586,7 @@
(define (trait-sum . ts)
(for-each (lambda (t)
(unless (trait? t)
(raise-type-error 'trait-sum "trait" t)))
(raise-argument-error 'trait-sum "trait?" t)))
ts)
(validate-trait
'trait-sum
@ -599,7 +599,7 @@
(define (:trait-exclude t name)
(unless (trait? t)
(raise-type-error 'trait-exclude "trait" t))
(raise-argument-error 'trait-exclude "trait?" t))
(let ([new-methods
(filter (lambda (m)
(not (member-name-key=? (method-name m) name)))
@ -613,7 +613,7 @@
(define (:trait-exclude-field t name)
(unless (trait? t)
(raise-type-error 'trait-exclude-field "trait" t))
(raise-argument-error 'trait-exclude-field "trait?" t))
(let ([new-fields
(filter (lambda (m)
(not (member-name-key=? (feeld-name m) name)))
@ -645,7 +645,7 @@
(define (:trait-alias t name new-name)
(unless (trait? t)
(raise-type-error 'trait-alias "trait" t))
(raise-argument-error 'trait-alias "trait?" t))
(let ([m (ormap (lambda (m)
(and (member-name-key=? (method-name m) name)
m))
@ -664,7 +664,7 @@
(define (:trait-rename t name new-name)
(unless (trait? t)
(raise-type-error 'trait-rename "trait" t))
(raise-argument-error 'trait-rename "trait?" t))
(let ([rename (lambda (n)
(if (same-name? n name)
new-name
@ -683,7 +683,7 @@
(define (:trait-rename-field t name new-name)
(unless (trait? t)
(raise-type-error 'trait-rename-field "trait" t))
(raise-argument-error 'trait-rename-field "trait?" t))
(let ([rename (lambda (n)
(if (same-name? n name)
new-name

2
collects/racket/udp.rkt
View File

@ -31,4 +31,4 @@
[(socket port-numbers?)
(if (udp? socket)
(tcp-addresses socket port-numbers?)
(raise-type-error 'udp-addresses "udp socket" socket))])))
(raise-argument-error 'udp-addresses "udp?" socket))])))

79
collects/racket/vector.rkt
View File

@ -25,34 +25,22 @@
(define (vector-copy v [start 0] [end (and (vector? v) (vector-length v))])
(unless (vector? v)
(raise-type-error 'vector-copy "vector" v))
(raise-argument-error 'vector-copy "vector?" v))
(unless (exact-nonnegative-integer? start)
(raise-type-error 'vector-copy "non-negative exact integer" start))
(raise-argument-error 'vector-copy "exact-nonnegative-integer?" start))
(let ([len (vector-length v)])
(cond
[(= len 0)
(unless (= start 0)
(raise-mismatch-error 'vector-copy
"start index must be 0 for empty vector, got "
start))
(raise-range-error 'vector-copy "vector" "starting " start v 0 0))
(unless (= end 0)
(raise-mismatch-error 'vector-copy
"end index must be 0 for empty vector, got "
end))
(raise-range-error 'vector-copy "vector" "ending " end v 0 0))
(vector)]
[else
(unless (and (<= 0 start len))
(raise-mismatch-error
'vector-copy
(format "start index ~e out of range [~e, ~e] for vector: "
start 0 len)
v))
(raise-range-error 'vector-copy "vector" "starting " start v 0 len))
(unless (and (<= start end len))
(raise-mismatch-error
'vector-copy
(format "end index ~e out of range [~e, ~e] for vector: "
end start len)
v))
(raise-range-error 'vector-copy "vector" "ending " end v start len 0))
(vector-copy* v start end)])))
;; do vector-map, putting the result in `target'
@ -69,14 +57,14 @@
;; uses name for error reporting
(define (varargs-check f v vs name)
(unless (procedure? f)
(apply raise-type-error name "procedure" 0 f v vs))
(apply raise-argument-error name "procedure?" 0 f v vs))
(unless (vector? v)
(apply raise-type-error name "vector" 1 f v vs))
(apply raise-argument-error name "vector?" 1 f v vs))
(let ([len (unsafe-vector-length v)])
(for ([e (in-list vs)]
[i (in-naturals 2)])
(unless (vector? e)
(apply raise-type-error name "vector" e i f v vs))
(apply raise-argument-error name "vector?" e i f v vs))
(unless (= len (unsafe-vector-length e))
(raise
(make-exn:fail:contract
@ -92,12 +80,9 @@
(sub1 (length args))))))
(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))
(raise-arguments-error name "mismatch between procedure arity and argument count"
"procedure" f
"expected arity" (add1 (length vs))))
len))
(define (vector-map f v . vs)
@ -115,7 +100,7 @@
;; uses name for error reporting
(define (one-arg-check f v name)
(unless (and (procedure? f) (procedure-arity-includes? f 1))
(raise-type-error name "procedure (arity 1)" 0 f)))
(raise-argument-error name "(any/c . -> . any/c)" 0 f)))
(define (vector-filter f v)
(one-arg-check f v 'vector-filter)
@ -126,12 +111,15 @@
(list->vector (for/list ([i (in-vector v)] #:unless (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 (procedure? f)
(raise-argument-error 'vector-count "procedure?" f))
(unless (procedure-arity-includes? f (add1 (length vs)))
(raise-arguments-error 'vector-count "mismatch between procedure arity and argument count"
"procedure" f
"expected arity" (add1 (length vs))))
(unless (and (vector? v) (andmap vector? vs))
(raise-type-error
'vector-count "vector"
(raise-argument-error
'vector-count "vector?"
(ormap (lambda (x) (and (not (list? x)) x)) (cons v vs))))
(if (pair? vs)
(let ([len (vector-length v)])
@ -143,21 +131,18 @@
(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")))
(raise-arguments-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))
(raise-argument-error name "vector?" v))
(unless (exact-nonnegative-integer? n)
(raise-type-error name "non-negative exact integer" n))
(raise-argument-error name "exact-nonnegative-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))
(raise-range-error name "vector" "" n v 0 len))
len))
(define (vector-take v n)
@ -189,7 +174,7 @@
[lens (for/list ([e (in-list vs)] [i (in-naturals)])
(if (vector? e)
(unsafe-vector-length e)
(raise-type-error 'vector-append "vector" e i)))]
(raise-argument-error 'vector-append "vector?" e i)))]
[new-v (make-vector (apply + lens))])
(let loop ([start 0] [lens lens] [vs vs])
(when (pair? lens)
@ -203,13 +188,13 @@
(define (mk-min cmp name f xs)
(unless (and (procedure? f)
(procedure-arity-includes? f 1))
(raise-type-error name "procedure (arity 1)" f))
(raise-argument-error name "(any/c . -> . real?)" f))
(unless (and (vector? xs)
(< 0 (unsafe-vector-length xs)))
(raise-type-error name "non-empty vector" xs))
(raise-argument-error name "(and/c vector? (lambda (v) (positive? (vector-length v))))" 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))
(raise-result-error name "real?" init-min-var))
(if (unsafe-fx= (unsafe-vector-length xs) 1)
(unsafe-vector-ref xs 0)
(let-values ([(min* min-var*)
@ -218,8 +203,8 @@
([e (in-vector xs 1)])
(let ([new-min (f e)])
(unless (real? new-min)
(raise-type-error
name "procedure that returns real numbers" f))
(raise-result-error
name "real?" new-min))
(cond [(cmp new-min min-var)
(values e new-min)]
[else (values min min-var)])))])
@ -231,7 +216,7 @@
(define-syntax-rule (vm-mk name cmp)
(define (name val vec)
(unless (vector? vec)
(raise-type-error 'name "vector" 1 val vec))
(raise-argument-error 'name "vector?" 1 val vec))
(let ([sz (unsafe-vector-length vec)])
(let loop ([k 0])
(cond [(= k sz) #f]

124
collects/scribblings/reference/strings.scrbl
View File

@ -389,6 +389,7 @@ one between @racket[list] and @racket[list*].
'("Alpha" "Beta" "Gamma")))))
]}
@defproc[(string-join [strs (listof string?)] [sep string? " "]) string?]{
Appends the strings in @racket[strs], inserting @racket[sep] between
@ -400,57 +401,6 @@ each pair of strings in @racket[strs].
(string-join '("one" "two" "three" "four") " potato ")
]}
@; *********************************************************************
@; Meta note: these functions are intended to be newbie-friendly, so I'm
@; intentionally starting the descriptions with a short senstence that
@; describes the default behavior instead of diving straight to a
@; precise description.
@defproc[(string-trim [str string?]
[sep (or/c string? regexp?) #px"\\s+"]
[#:left? left? any/c #t]
[#:right? right? any/c #t]
[#:repeat? repeat? any/c #f])
string?]{
Trims the input @racket[str] by removing prefix and suffix whitespaces.
The optional @racket[sep] argument can be specified as either a string
or a (p)regexp to remove a different prefix/suffix; a string is matched
as-is. Use @racket[#:left?] or @racket[#:right?] to suppress trimming
one of these sides. When @racket[repeat?] is @racket[#f] (the default),
only one match is removed from each side, but when it is true any number
of matches is trimmed. (Note that with a regexp separator you can use
@litchar{+} instead.)
@mz-examples[#:eval string-eval
(string-trim " foo bar baz \r\n\t")
(string-trim " foo bar baz \r\n\t" " " #:repeat? #t)
(string-trim "aaaxaayaa" "aa")
]}
@defproc[(string-split [str string?]
[sep (or/c string? regexp?) #px"\\s+"]
[#:trim? trim? any/c #t]
[#:repeat? repeat? any/c #f])
(listof string?)]{
Splits the input @racket[str] on whitespaces, returning a list of
strings. The input is trimmed first.
Similarly to @racket[string-trim], @racket[sep] can be given as a string
or a (p)regexp to use a different separator, and @racket[repeat?]
controls matching repeated sequences. @racket[trim?] determines whether
trimming is done (the default).
@mz-examples[#:eval string-eval
(string-split " foo bar baz \r\n\t")
(string-split " ")
(string-split " " #:trim? #f)
]
(Note that unlike @racket[regexp-split], an empty input string results
in an empty list.)}
@defproc[(string-normalize-spaces [str string?]
[sep (or/c string? regexp?) #px"\\s+"]
@ -460,17 +410,17 @@ in an empty list.)}
string?]{
Normalizes spaces in the input @racket[str] by trimming it (using
@racket[string-trim]) and replacing all whitespace sequences in the
result with a single space.
You can specify @racket[space] for an alternate space replacement.
@racket[string-trim] and @racket[sep]) and replacing all whitespace
sequences in the result with @racket[space], which defaults to a
single space.
@mz-examples[#:eval string-eval
(string-normalize-spaces " foo bar baz \r\n\t")
]
Note that this is the same as
@racket[(string-join (string-split str sep ....) space)]}
The result of @racket[(string-normalize-spaces str sep space)] is the same
as @racket[(string-join (string-split str sep ....) space)].}
@defproc[(string-replace [str string?]
[from (or/c string? regexp?)]
@ -478,17 +428,65 @@ Note that this is the same as
[#:all all? any/c #t])
string?]{
Returns a copy of @racket[str] where all occurrences of @racket[from]
are replaced with with @racket[to].
Returns @racket[str] with all occurrences of @racket[from] replaced
with by @racket[to]. If @racket[from] is a string, it is matched
literally (as opposed to being used as a @tech{regular expression}).
When @racket[from] is a string it is matched literally. The replacement
@racket[to] argument must be a string and is always inserted as-is. All
occurrences are replaced by default, pass @racket[#f] for @racket[all?]
to replace only the first match.
By default, all occurrences are replaced, but only the first match is
replaced if @racket[all?] is @racket[#f].
@mz-examples[#:eval string-eval
(string-replace "foo bar baz" "bar" "blah")
]}
@defproc[(string-split [str string?]
[sep (or/c string? regexp?) #px"\\s+"]
[#:trim? trim? any/c #t]
[#:repeat? repeat? any/c #f])
(listof string?)]{
Splits the input @racket[str] on whitespaces, returning a list of
substrings of @racket[str] that are separated by @racket[sep]. The
input is first trimmed using @racket[sep] (see @racket[string-trim]),
unless @racket[trim?] is @racket[#f]. Empty matches are handled in the
same way as for @racket[regexp-split]. As a special case, if
@racket[str] is the empty string after trimming, the result is
@racket['()] instead of @racket['("")].
Like @racket[string-trim], provide @racket[sep] to use a different separator,
and @racket[repeat?] controls matching repeated sequences.
@mz-examples[#:eval string-eval
(string-split " foo bar baz \r\n\t")
(string-split " ")
(string-split " " #:trim? #f)
]}
@defproc[(string-trim [str string?]
[sep (or/c string? regexp?) #px"\\s+"]
[#:left? left? any/c #t]
[#:right? right? any/c #t]
[#:repeat? repeat? any/c #f])
string?]{
Trims the input @racket[str] by removing prefix and suffix @racket[sep],
which defaults to whitespace. A string @racket[sep] is matched literally
(as opposed to being used as a @tech{regular expression}).
Use @racket[#:left? #f] or @racket[#:right? #f] to suppress trimming
the corresponding side. When @racket[repeat?] is @racket[#f] (the
default), only one match is removed from each side; when
@racket[repeat?] it is true, all initial or trailing matches are
trimmed (which is an alternative to using a @tech{regular expression}
@racket[sep] that contains @litchar{+}).
@mz-examples[#:eval string-eval
(string-trim " foo bar baz \r\n\t")
(string-trim " foo bar baz \r\n\t" " " #:repeat? #t)
(string-trim "aaaxaayaa" "aa")
]}
@close-eval[string-eval]

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

@ -348,13 +348,13 @@
(test '(1 banana) argmin car '((3 pears) (1 banana) (2 apples)))
(err/rt-test (argmin 1 (list 1)) (check-regs #rx"argmin" #rx"procedure"))
(err/rt-test (argmin 1 (list 1)) (check-regs #rx"argmin" #rx"any/c . -> . real[?]"))
(err/rt-test (argmin (lambda (x) x) 3) (check-regs #rx"argmin" #rx"list"))
(err/rt-test (argmin (lambda (x) x) (list 1 #f)) (check-regs #rx"argmin" #rx"procedure that returns real numbers"))
(err/rt-test (argmin (lambda (x) x) (list #f)) (check-regs #rx"argmin" #rx"procedure that returns real numbers"))
(err/rt-test (argmin (lambda (x) x) (list 1 #f)) (check-regs #rx"argmin" #rx"real"))
(err/rt-test (argmin (lambda (x) x) (list #f)) (check-regs #rx"argmin" #rx"real"))
(err/rt-test (argmin (lambda (x) x) (list +i)) (check-regs #rx"argmin" #rx"procedure that returns real numbers"))
(err/rt-test (argmin (lambda (x) x) (list)) (check-regs #rx"argmin" #rx"non-empty list"))
(err/rt-test (argmin (lambda (x) x) (list +i)) (check-regs #rx"argmin" #rx"real"))
(err/rt-test (argmin (lambda (x) x) (list)) (check-regs #rx"argmin" #rx".and/c list[?] .not/c empty[?].."))
(test 'argmax object-name argmax)
(test 1 argmax (lambda (x) 0) (list 1))
@ -370,13 +370,13 @@
(test '(3 pears) argmax car '((3 pears) (1 banana) (2 apples)))
(err/rt-test (argmax 1 (list 1)) (check-regs #rx"argmax" #rx"procedure"))
(err/rt-test (argmax 1 (list 1)) (check-regs #rx"argmax" #rx"any/c . -> . real[?]"))
(err/rt-test (argmax (lambda (x) x) 3) (check-regs #rx"argmax" #rx"list"))
(err/rt-test (argmax (lambda (x) x) (list 1 #f)) (check-regs #rx"argmax" #rx"procedure that returns real numbers"))
(err/rt-test (argmax (lambda (x) x) (list #f)) (check-regs #rx"argmax" #rx"procedure that returns real numbers"))
(err/rt-test (argmax (lambda (x) x) (list 1 #f)) (check-regs #rx"argmax" #rx"real"))
(err/rt-test (argmax (lambda (x) x) (list #f)) (check-regs #rx"argmax" #rx"real"))
(err/rt-test (argmax (lambda (x) x) (list +i)) (check-regs #rx"argmax" #rx"procedure that returns real numbers"))
(err/rt-test (argmax (lambda (x) x) (list)) (check-regs #rx"argmax" #rx"non-empty list")))
(err/rt-test (argmax (lambda (x) x) (list +i)) (check-regs #rx"argmax" #rx"real?"))
(err/rt-test (argmax (lambda (x) x) (list)) (check-regs #rx"argmax" #rx".and/c list[?] .not/c empty[?]..")))
;; ---------- range ----------

2
collects/tests/racket/sandbox.rktl
View File

@ -484,7 +484,7 @@
(make-base-evaluator/reqs! '(racket/list))
--eval--
(last-pair '(1 2 3)) => '(3)
(last-pair null) =err> "expected argument of type"
(last-pair null) =err> "contract violation"
;; coverage
--top--

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

@ -165,13 +165,13 @@
(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 1 (vector 1)) (check-regs #rx"vector-argmin" #rx"any/c . -> . real"))
(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 1 #f)) (check-regs #rx"vector-argmin" #rx"real"))
(err/rt-test (vector-argmin (lambda (x) x) (vector #f)) (check-regs #rx"vector-argmin" #rx"real"))
(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"))
(err/rt-test (vector-argmin (lambda (x) x) (vector +i)) (check-regs #rx"vector-argmin" #rx"real"))
(err/rt-test (vector-argmin (lambda (x) x) (vector)) (check-regs #rx"vector-argmin" #rx".and/c vector.*vector-length"))
(test 'vector-argmax object-name vector-argmax)
(test 1 vector-argmax (lambda (x) 0) (vector 1))
@ -187,13 +187,13 @@
(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 1 (vector 1)) (check-regs #rx"vector-argmax" #rx"any/c . -> . real"))
(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 1 #f)) (check-regs #rx"vector-argmax" #rx"real"))
(err/rt-test (vector-argmax (lambda (x) x) (vector #f)) (check-regs #rx"vector-argmax" #rx"real"))
(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 +i)) (check-regs #rx"vector-argmax" #rx"real"))
(err/rt-test (vector-argmax (lambda (x) x) (vector)) (check-regs #rx"vector-argmax" #rx".and/c vector.*vector-length")))
;; vector-mem{ber,v,q}
@ -221,11 +221,11 @@
(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 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")))
(err/rt-test (vector-map (lambda (x) x) #() #() #()) (check-regs #rx"vector-map" #rx"mismatch between procedure arity")))
;; ---------- check no collisions with srfi/43 ----------