diff --git a/collects/mred/private/app.rkt b/collects/mred/private/app.rkt index 1e9bfff1..c4a66e66 100644 --- a/collects/mred/private/app.rkt +++ b/collects/mred/private/app.rkt @@ -55,9 +55,9 @@ (when proc (unless (and (procedure? proc) (procedure-arity-includes? proc arity)) - (raise-type-error who - (format "procedure (arity ~a) or #f" arity) - proc))) + (raise-argument-error who + (format "(or/c (procedure-arity-includes/c ~a) #f)" arity) + proc))) (let ([e (wx:current-eventspace)]) (when (wx:main-eventspace? e) (param (make-app-handler @@ -178,9 +178,10 @@ (with-handlers ([exn:fail? (lambda (x) (if (wx:eventspace-shutdown? e) - (raise-mismatch-error + (raise-arguments-error 'eventspace-handler-thread - "eventspace is shutdown: " + "eventspace is shutdown" + "eventspace" e) (raise x)))]) (let ([done (make-semaphore)] diff --git a/collects/mred/private/check.rkt b/collects/mred/private/check.rkt index 365d373c..32cfc070 100644 --- a/collects/mred/private/check.rkt +++ b/collects/mred/private/check.rkt @@ -45,62 +45,68 @@ (when p (let ([wx (mred->wx p)]) (unless wx - (raise-mismatch-error (who->name cwho) - "container is not yet fully initialized: " - p))))) + (raise-arguments-error (who->name cwho) + "container is not yet fully initialized" + "container" p))))) (define (check-instance who class class-name false-ok? v) (unless (or (and false-ok? (not v)) (is-a? v class)) - (raise-type-error (who->name who) (format "~a object~a" class-name (if false-ok? " or #f" "")) v))) + (raise-argument-error (who->name who) + (let ([c (format "(is-a?/c ~a)" class-name)]) + (if false-ok? + (format "(or/c ~a #f)" c) + c)) + v))) (define (check-string/false who str) (unless (or (not str) (string? str)) - (raise-type-error (who->name who) "string or #f" str))) + (raise-argument-error (who->name who) "(or/c string? #f)" str))) (define (check-path who str) (unless (path-string? str) - (raise-type-error (who->name who) "path or string" str))) + (raise-argument-error (who->name who) "path-string?" str))) (define (check-path/false who str) (unless (or (not str) (path-string? str)) - (raise-type-error (who->name who) "path, string, or #f" str))) + (raise-argument-error (who->name who) "(or/c path-string? #f)" str))) (define (check-string who str) (unless (string? str) - (raise-type-error (who->name who) "string" str))) + (raise-argument-error (who->name who) "string?" str))) (define (check-label-string who str) (unless (label-string? str) - (raise-type-error (who->name who) "string (up to 200 characters)" str))) + (raise-argument-error (who->name who) "label-string?" str))) (define (check-label-string/false who str) (unless (or (not str) (label-string? str)) - (raise-type-error (who->name who) "string (up to 200 characters) or #f" str))) + (raise-argument-error (who->name who) "(or/c label-string? #f)" str))) (define (check-char/false who c) (unless (or (not c) (char? c)) - (raise-type-error (who->name who) "character or #f" c))) + (raise-argument-error (who->name who) "(or/c char? #f)" c))) (define (check-callback who callback) (unless (and (procedure? callback) (procedure-arity-includes? callback 2)) - (raise-type-error (who->name who) "procedure of arity 2" callback))) + (raise-argument-error (who->name who) "(procedure-arity-includes/c 2)" callback))) (define (check-callback1 who callback) (unless (and (procedure? callback) (procedure-arity-includes? callback 1)) - (raise-type-error (who->name who) "procedure of arity 1" callback))) + (raise-argument-error (who->name who) "(procedure-arity-includes/c 2)" callback))) (define (check-bounded-integer min max false-ok?) (lambda (who range) (unless (or (and false-ok? (not range)) (and (integer? range) (exact? range) (<= min range max))) - (raise-type-error (who->name who) - (format "exact integer in [~a, ~a]~a" - min max - (if false-ok? " or #f" "")) - range)))) - + (raise-argument-error (who->name who) + (let ([i (format "(integer-in ~a ~a)" min max)]) + (if false-ok? + (format "(or/c ~a #f)" i) + i)) + range)))) + (define check-range-integer (check-bounded-integer 0 10000 #f)) (define check-slider-integer (check-bounded-integer -10000 10000 #f)) @@ -116,24 +122,24 @@ (not (and (integer? wheel-step) (exact? wheel-step) (<= 1 wheel-step 10000)))) - (raise-type-error (who->name cwho) - "#f or exact integer in [1,10000]" - wheel-step))) + (raise-argument-error (who->name cwho) + "(or/c #f (integer-in 1 10000))" + wheel-step))) (define (check-fraction who x) (unless (and (real? x) (<= 0.0 x 1.0)) - (raise-type-error (who->name who) - "real number in [0.0, 1.0]" - x))) + (raise-argument-error (who->name who) + "(real-in 0.0 1.0)" + x))) (define (-check-non-negative-integer who i false-ok?) (when (or i (not false-ok?)) (unless (and (integer? i) (exact? i) (not (negative? i))) - (raise-type-error (who->name who) - (if false-ok? - "non-negative exact integer or #f" - "non-negative exact integer" ) - i)))) + (raise-argument-error (who->name who) + (if false-ok? + "(or/c exact-nonnegative-integer? #f)" + "exact-nonnegative-integer?") + i)))) (define (check-non-negative-integer who i) (-check-non-negative-integer who i #f)) @@ -146,7 +152,7 @@ (define (check-label-string-or-bitmap who label) (unless (or (label-string? label) (is-a? label wx:bitmap%)) - (raise-type-error (who->name who) "string (up to 200 characters) or bitmap% object" label))) + (raise-argument-error (who->name who) "(or/c label-string? (is-a?/c bitmap%))" label))) (define (check-label-string-or-bitmap-or-both who label) (unless (or (label-string? label) (is-a? label wx:bitmap%) @@ -155,54 +161,62 @@ (is-a? (car label) wx:bitmap%) (label-string? (cadr label)) (memq (caddr label) '(left right top bottom)))) - (raise-type-error (who->name who) - (string-append - "string (up to 200 characters), bitmap% object, or list of bitmap%, " - "string, and image-placement symbol ('left, 'right, 'top, or 'bottom)") - label))) + (raise-argument-error (who->name who) + (string-append + "(or/c label-string?\n" + " (is-a?/c bitmap%)\n" + " (list/c (is-a?/c bitmap%)\n" + " string\n" + " (or/c 'left 'right 'top 'bottom)))") + label))) (define (check-label-string-or-bitmap/false who label) (unless (or (not label) (label-string? label) (is-a? label wx:bitmap%)) - (raise-type-error (who->name who) "string (up to 200 characters), bitmap% object, or #f" label))) + (raise-argument-error (who->name who) "(or/c label-string? (is-a?/c bitmap%) #f)" label))) (define (check-label-string/bitmap/iconsym who label) (unless (or (label-string? label) (is-a? label wx:bitmap%) (memq label '(app caution stop))) - (raise-type-error (who->name who) "string (up to 200 characters), bitmap% object, or icon symbol" label))) + (raise-argument-error (who->name who) "(or/c label-string? (is-a?/c bitmap%) 'app 'caution 'stop)" label))) (define (check-font who f) (unless (or (eq? f no-val) (f . is-a? . wx:font%)) - (raise-type-error (who->name who) "font% object" f))) + (raise-argument-error (who->name who) "(is-a?/c font%)" f))) (define (check-style who reqd other-allowed style) (unless (and (list? style) (andmap symbol? style)) - (raise-type-error (who->name who) "list of style symbols" style)) + (raise-argument-error (who->name who) "(listof symbol?)" style)) (when reqd - (letrec ([or-together (lambda (l) - (if (= (length l) 2) - (format "~a or ~a" (car l) (cadr l)) - (let loop ([l l]) - (if (null? (cdr l)) - (format "or ~a" (car l)) - (format "~a, ~a" (car l) (loop (cdr l)))))))]) - (unless (ormap (lambda (i) (memq i reqd)) style) - (raise-type-error (who->name who) - (format "style list, missing ~a" - (if (= (length reqd) 1) - (car reqd) - (string-append - "one of " - (or-together reqd)))) - style)))) + (unless (ormap (lambda (i) (memq i reqd)) style) + (letrec ([or-together (lambda (l) + (if (= (length l) 2) + (format "~e or ~e" (car l) (cadr l)) + (let loop ([l l]) + (if (null? (cdr l)) + (format "or ~e" (car l)) + (format "~e, ~a" (car l) (loop (cdr l)))))))]) + (raise-arguments-error (who->name who) + (string-append + "missing a required option in given style list\n" + " must include: " (or-together reqd)) + "given" style)))) (if (and (not reqd) (null? other-allowed)) (unless (null? style) - (raise-type-error (who->name who) "empty style list" style)) + (raise-arguments-error (who->name who) + "empty style list required" + "given" style)) (let* ([l (append (or reqd null) other-allowed)] [bad (ormap (lambda (x) (if (memq x l) #f x)) style)]) (when bad - (raise-type-error (who->name who) (format "style list, ~e not allowed" bad) style)) + (raise-arguments-error (who->name who) + "invalid symbol in given style list" + "invalid symbol" bad + "given" style)) (let loop ([l style]) (unless (null? l) (when (memq (car l) (cdr l)) - (raise-type-error (who->name who) (format "style list, ~e allowed only once" (car l)) style)) + (raise-arguments-error (who->name who) + "duplicate style in given style list" + "duplicate" (car l) + "given" style)) (loop (cdr l)))))))) diff --git a/collects/mred/private/editor.rkt b/collects/mred/private/editor.rkt index 551f0dea..b2b18b68 100644 --- a/collects/mred/private/editor.rkt +++ b/collects/mred/private/editor.rkt @@ -61,9 +61,9 @@ (define (check-format who format) (unless (memq format '(guess standard text text-force-cr same copy)) - (raise-type-error (who->name who) - "'guess, 'standard, 'text, 'text-force-cr, 'same, or 'copy" - format))) + (raise-argument-error (who->name who) + "(or/c 'guess 'standard 'text 'text-force-cr 'same 'copy)" + format))) (define-syntax (augmentize stx) (syntax-case stx () @@ -378,7 +378,7 @@ (entry-point (lambda (type) (unless (memq type '(text pasteboard)) - (raise-type-error (who->name '(method editor<%> on-new-box)) "symbol: text or pasteboard" type)) + (raise-argument-error (who->name '(method editor<%> on-new-box)) "(or/c 'text 'pasteboard)" type)) (make-object editor-snip% (let ([e (make-object (cond [(eq? type 'pasteboard) pasteboard%] @@ -557,9 +557,9 @@ (lambda (p) (unless (and (procedure? p) (procedure-arity-includes? p 1)) - (raise-type-error who - "procedure of arity 1" - p)) + (raise-argument-error who + "(procedure-arity-includes/c 1)" + p)) p)) (define current-text-keymap-initializer diff --git a/collects/mred/private/filedialog.rkt b/collects/mred/private/filedialog.rkt index cd5a92bb..3707b12f 100644 --- a/collects/mred/private/filedialog.rkt +++ b/collects/mred/private/filedialog.rkt @@ -37,7 +37,7 @@ (string? (car p)) (string? (cadr p)))) filters)) - (raise-type-error who "list of 2-string lists" filters)) + (raise-argument-error who "(listof (list/c string? string?))" filters)) (let* ([std? (memq 'common style)] [style (if std? (remq 'common style) style)]) (if std? diff --git a/collects/mred/private/misc.rkt b/collects/mred/private/misc.rkt index 28ea2213..dcd644ec 100644 --- a/collects/mred/private/misc.rkt +++ b/collects/mred/private/misc.rkt @@ -41,7 +41,7 @@ (define (sleep/yield secs) (unless (and (real? secs) (not (negative? secs))) - (raise-type-error 'sleep/yield "non-negative real number" secs)) + (raise-argument-error 'sleep/yield "(>=/c 0.0)" secs)) (let ([evt (alarm-evt (+ (current-inexact-milliseconds) (* secs 1000)))]) ;; First, allow at least some events to be handled even if @@ -126,8 +126,8 @@ (follow)))))) (define (play-sound f async?) - (unless (or (path? f) (string? f)) - (raise-type-error 'play-sound "string-or-path" f)) + (unless (path-string? f) + (raise-argument-error 'play-sound "path-string?" f)) (unless (file-exists? f) (error 'play-sound "file not found: ~e" f)) ((if (eq? (system-type) 'unix) (force unix-play-command) wx:play-sound) diff --git a/collects/mred/private/moredialogs.rkt b/collects/mred/private/moredialogs.rkt index 4557c828..bec55f36 100644 --- a/collects/mred/private/moredialogs.rkt +++ b/collects/mred/private/moredialogs.rkt @@ -236,15 +236,15 @@ (check-label-string 'get-choices-from-user title) (check-label-string/false 'get-choices-from-user message) (unless (and (list? choices) (andmap label-string? choices)) - (raise-type-error 'get-choices-from-user "list of strings (up to 200 characters)" choices)) + (raise-argument-error 'get-choices-from-user "(listof label-string?)" choices)) (check-top-level-parent/false 'get-choices-from-user parent) - (unless (and (list? init-vals) (andmap (lambda (x) (and (integer? x) (exact? x) (not (negative? x)))) init-vals)) - (raise-type-error 'get-choices-from-user "list of exact non-negative integers" init-vals)) + (unless (and (list? init-vals) (andmap exact-nonnegative-integer? init-vals)) + (raise-argument-error 'get-choices-from-user "(listof exact-nonnegative-integer?)" init-vals)) (check-style 'get-choices-from-user '(single multiple extended) null style) (when (and (memq 'single style) (> (length init-vals) 1)) - (raise-mismatch-error 'get-choices-from-user - (format "multiple initial-selection indices provided with ~e style: " 'single) - init-vals)) + (raise-arguments-error 'get-choices-from-user + "multiple initial-selection indices provided with 'single style" + "indices" init-vals)) (let* ([f (make-object dialog% title parent box-width (min 300 (max 150 (* 14 (length choices)))))] [ok-button #f] [update-ok (lambda (l) (send ok-button enable (not (null? (send l get-selections)))))] @@ -259,11 +259,12 @@ [p (make-object horizontal-pane% f)]) (for-each (lambda (i) (when (>= i (send l get-number)) - (raise-mismatch-error - 'get-choices-from-user - (format "inital-selection list specifies an out-of-range index (~e choices provided): " - (send l get-number)) - i)) + (raise-arguments-error + 'get-choices-from-user + "out of range;\n inital-selection list specifies an out-of-range index" + "index" i + "provided choices" (send l get-number) + "list..." init-vals)) (send l select i #t)) init-vals) (send p set-alignment 'right 'center) (send p stretchable-height #f) diff --git a/collects/mred/private/mrcanvas.rkt b/collects/mred/private/mrcanvas.rkt index e26c6df1..627f831d 100644 --- a/collects/mred/private/mrcanvas.rkt +++ b/collects/mred/private/mrcanvas.rkt @@ -50,13 +50,13 @@ (public get-dc) (define/public (make-bitmap w h) (unless (exact-positive-integer? w) - (raise-type-error (who->name '(method canvas% make-bitmap)) - "exact positive integer" - w)) + (raise-argument-error (who->name '(method canvas% make-bitmap)) + "exact-positive-integer?" + w)) (unless (exact-positive-integer? h) - (raise-type-error (who->name '(method canvas% make-bitmap)) - "exact positive integer" - h)) + (raise-argument-error (who->name '(method canvas% make-bitmap)) + "exact-positive-integer?" + h)) (send wx make-compatible-bitmap w h)) (define/public (suspend-flush) @@ -69,13 +69,13 @@ (entry-point (lambda (c) (unless (c . is-a? . wx:color%) - (raise-type-error (who->name '(method canvas<%> set-canvas-background)) - "color% object" - c)) - (unless (send wx get-canvas-background) - (raise-mismatch-error (who->name '(method canvas<%> set-canvas-background)) - "cannot set a transparent canvas's background color: " + (raise-argument-error (who->name '(method canvas<%> set-canvas-background)) + "(is-a?/c color%)" c)) + (unless (send wx get-canvas-background) + (raise-arguments-error (who->name '(method canvas<%> set-canvas-background)) + "cannot set a transparent canvas's background color" + "given color" c)) (send wx set-canvas-background c)))) (public set-canvas-background) (define get-canvas-background @@ -179,27 +179,27 @@ (check-range-integer who x-val) (check-range-integer who y-val) (when (and x-len (< x-len x-val)) - (raise-mismatch-error (who->name who) - (format "horizontal value: ~e larger than the horizontal range: " - x-val) - x-len)) + (raise-arguments-error (who->name who) + "horizontal value is larger than the horizontal range" + "value" x-val + "range" x-len)) (when (and y-len (< y-len y-val)) - (raise-mismatch-error (who->name who) - (format "vertical value: ~e larger than the vertical range: " - y-val) - y-len))) + (raise-arguments-error (who->name who) + "vertical value is larger than the vertical range" + "value" y-val + "range" y-len))) (send wx set-scrollbars (if x-len 1 0) (if y-len 1 0) (or x-len 0) (or y-len 0) x-page y-page x-val y-val #f)) (define/public (show-scrollbars x-on? y-on?) (let ([bad (lambda (which what) - (raise-mismatch-error + (raise-arguments-error (who->name '(method canvas% show-scrollbars)) (format - "cannot show ~a scrollbars, because the canvas style did not include ~a: " + "cannot show ~a scrollbars;\n the canvas style did not include ~a" which what) - this))]) + "canvas" this))]) (when x-on? (unless has-x? (bad "horizontal" 'hscroll))) (when y-on? (unless has-y? (bad "vertical" 'vscroll))) (send wx show-scrollbars x-on? y-on?))) diff --git a/collects/mred/private/mrcontainer.rkt b/collects/mred/private/mrcontainer.rkt index 8ec0be80..b99b0a1f 100644 --- a/collects/mred/private/mrcontainer.rkt +++ b/collects/mred/private/mrcontainer.rkt @@ -33,7 +33,10 @@ (define (check-container-parent who p) (unless (is-a? p internal-container<%>) - (raise-type-error (who->name who) "built-in container<%> object" p))) + (unless (is-a? p area-container<%>) + (raise-argument-error (who->name who) "(is-a?/c area-container<%>)" p)) + (raise-arguments-error (who->name who) "invalid container;\n given container is not an instance of a built-in container class" + "given container" p))) (define-local-member-name has-wx-child? @@ -54,7 +57,7 @@ (= 2 (length alignment)) (memq (car alignment) '(left center right)) (memq (cadr alignment) '(top center bottom))) - (raise-type-error (who->name cwho) "alignment list" alignment)))) + (raise-argument-error (who->name cwho) "(list/c (or/c 'left center right) (or/c 'top 'center 'bottom))" alignment)))) (define get-wx-panel get-wx-pan) (define bdr (param get-wx-panel border)) @@ -81,9 +84,9 @@ (lambda (f) (unless (and (procedure? f) (procedure-arity-includes? f 1)) - (raise-type-error (who->name '(method container<%> change-children)) - "procedure of arity 1" - f)) + (raise-argument-error (who->name '(method container<%> change-children)) + "(procedure-arity-includes/c 1)" + f)) (send (get-wx-panel) change-children (lambda (kids) (let* ([hidden (send (get-wx-panel) get-hidden-child)] @@ -91,9 +94,10 @@ [l (as-exit (lambda () (f mred-kids)))]) (unless (and (list? l) (andmap (lambda (x) (is-a? x internal-subarea<%>)) l)) - (raise-mismatch-error 'change-children - "result of given procedure was not a list of subareas: " - l)) + (raise-arguments-error 'change-children + "result of given procedure was not a list of subareas" + "procedure" f + "result" l)) (append (if hidden (list hidden) null) (map mred->wx l)))))))] @@ -107,9 +111,9 @@ (integer? (car l)) (exact? (car l)) (<= 0 (car l) 10000) (integer? (cadr l)) (exact? (cadr l)) (<= 0 (cadr l) 10000))) l)) - (raise-type-error (who->name '(method area-container<%> container-size)) - "list of lists containing two exact integers in [0, 10000] and two booleans" - l)) + (raise-argument-error (who->name '(method area-container<%> container-size)) + "(listof (list/c (integer-in 0 10000) (integer-in 0 10000) any/c any/c))" + l)) (let ([l (send (get-wx-panel) do-get-graphical-min-size)]) (apply values l))))] [place-children (entry-point (lambda (l w h) (send (get-wx-panel) do-place-children l w h)))] @@ -155,19 +159,20 @@ (let ([p1 (send (mred->wx this) get-top-level)] [p2 (send (mred->wx new-parent) get-top-level)]) (eq? (send p1 get-eventspace) (send p1 get-eventspace))))) - (raise-mismatch-error + (raise-arguments-error (who->name '(subwindow<%> reparent)) - "current parent's eventspace is not the same as the eventspace of the new parent: " - new-parent)) + "current parent's eventspace is not the same as the eventspace of the new parent" + "subwindow" this + "new parent" new-parent)) (let loop ([p new-parent]) (when p (when (eq? p this) - (raise-mismatch-error + (raise-arguments-error (who->name '(subwindow<%> reparent)) (if (eq? new-parent this) - "cannot set parent to self: " - "cannot set parent to a descedant: ") - new-parent)) + "cannot set parent to self" + "cannot set parent to a descedant") + "subwindow" this)) (loop (send p get-parent)))) (let* ([added? (memq this (send (get-parent) get-children))] [shown? (and added? (is-shown?))]) diff --git a/collects/mred/private/mred.rkt b/collects/mred/private/mred.rkt index 87e4af73..6e26e1b2 100644 --- a/collects/mred/private/mred.rkt +++ b/collects/mred/private/mred.rkt @@ -160,7 +160,7 @@ (define (find-graphical-system-path what) (unless (memq what '(init-file x-display)) - (raise-type-error 'find-graphical-system-path "'init-file or 'x-display" what)) + (raise-argument-error 'find-graphical-system-path "(or/c 'init-file 'x-display)" what)) (or (wx:find-graphical-system-path what) (case what [(init-file) diff --git a/collects/mred/private/mritem.rkt b/collects/mred/private/mritem.rkt index 74458c25..78108061 100644 --- a/collects/mred/private/mritem.rkt +++ b/collects/mred/private/mritem.rkt @@ -340,7 +340,7 @@ (unless (and (list? chcs) (pair? chcs) (or (andmap label-string? chcs) (andmap (lambda (x) (is-a? x wx:bitmap%)) chcs))) - (raise-type-error (who->name cwho) "non-empty list of strings (up to 200 characters) or bitmap% objects" chcs)) + (raise-argument-error (who->name cwho) "(or/c (non-empty-listof label-string?) (non-empty-listof (is-a?/c bitmap%)))" chcs)) (check-container-parent cwho parent) (check-callback cwho callback) (check-orientation cwho style) @@ -355,7 +355,8 @@ `(method radio-box% ,method) n) (when n (unless (< n (length chcs)) - (raise-mismatch-error (who->name `(method radio-box% ,method)) "no such button: " n))))]) + (raise-arguments-error (who->name `(method radio-box% ,method)) "no such button" + "index" n))))]) (override* [enable (entry-point (case-lambda @@ -398,11 +399,7 @@ (let ([cwho '(constructor radio-box)]) (check-container-ready cwho parent) (when selection - (unless (< selection (length choices)) - (raise-mismatch-error (who->name cwho) - (format "initial selection is too large, given only ~a choices: " - (length choices)) - selection))))) + (check-list-control-selection cwho choices selection)))) label parent callback #f) [font font] [enabled enabled] @@ -440,15 +437,16 @@ (check-style cwho '(vertical horizontal) '(plain vertical-label horizontal-label deleted) style) (check-font cwho font) (unless (<= minv maxv) - (raise-mismatch-error (who->name cwho) - (format "minumum value: ~e is greater than maximum value: " minv) - maxv)) + (raise-arguments-error (who->name cwho) + "minumum value is greater than maximum value" + "minimum" minv + "maximum" maxv)) (unless (<= minv init-value maxv) - (raise-mismatch-error (who->name cwho) - (format "minumum value: ~e and maximum value: ~e do no bound initial value: " - minv - maxv) - init-value))) + (raise-arguments-error (who->name cwho) + "range error;\n initial value is not between minumum value and maximum value inclusive" + "initial value" init-value + "minimum" minv + "maximum" maxv))) (define wx #f) (public* [get-value (entry-point (lambda () (send wx get-value)))] @@ -456,10 +454,11 @@ (lambda (v) (check-slider-integer '(method slider% set-value) v) (unless (<= minv v maxv) - (raise-mismatch-error (who->name '(method slider% set-value)) - (format "slider's range is ~a to ~a; cannot set the value to: " - minv maxv) - v)) + (raise-arguments-error (who->name '(method slider% set-value)) + "out of range;\n given value is not between minimum and maximum values" + "given" v + "minimum" minv + "maximum" maxv)) (send wx set-value v)))]) (as-entry (lambda () @@ -512,10 +511,10 @@ (lambda (v) (check-range-integer '(method gauge% set-value) v) (when (> v (send wx get-range)) - (raise-mismatch-error (who->name '(method gauge% set-value)) - (format "gauge's range is 0 to ~a; cannot set the value to: " - (send wx get-range)) - v)) + (raise-arguments-error (who->name '(method gauge% set-value)) + "out of range;\n given value is not between 0 and maximum value" + "given" v + "maximum" (send wx get-range))) (send wx set-value v)))] [get-range (entry-point (lambda () (send wx get-range)))] [set-range (entry-point @@ -595,8 +594,9 @@ (let ([pos (do-find-string s)]) (if pos (send wx set-selection pos) - (raise-mismatch-error (who->name '(method list-control<%> set-string-selection)) - "no item matching the given string: " s)))))] + (raise-arguments-error (who->name '(method list-control<%> set-string-selection)) + "no item matching the given string" + "given" s)))))] [find-string (entry-point (lambda (x) (check-label-string '(method list-control<%> find-string) x) (do-find-string x)))] @@ -629,12 +629,13 @@ (check-non-negative-integer `(method list-control<%> ,method) n) (let ([m (send wx number)]) (unless (< n m) - (raise-mismatch-error (who->name `(method list-control<%> ,method)) - (if (zero? m) - "control has no items; given index: " - (format "control has only ~a items, indexed 0 to ~a; given out-of-range index: " - m (sub1 m))) - n))))]) + (raise-range-error (who->name `(method list-control<%> ,method)) + "control" "item " + n + this + 0 + (sub1 m) + #f))))]) (as-entry (lambda () (super-make-object (lambda () (set! wx (mk-wx)) wx) mismatches label parent callback #f))) @@ -644,16 +645,16 @@ (define (check-list-control-args cwho label choices parent callback) (check-label-string/false cwho label) (unless (and (list? choices) (andmap label-string? choices)) - (raise-type-error (who->name cwho) "list of strings (up to 200 characters)" choices)) + (raise-argument-error (who->name cwho) "(listof label-string?)" choices)) (check-container-parent cwho parent) (check-callback cwho callback)) (define (check-list-control-selection cwho choices selection) (unless (< selection (length choices)) - (raise-mismatch-error (who->name cwho) - (format "initial selection is too large, given only ~a choices: " - (length choices)) - selection))) + (raise-arguments-error (who->name cwho) + "given initial selection is too large" + "given" selection + "choice count" (length choices)))) (define choice% (class basic-list-control% @@ -725,34 +726,36 @@ (unless (and (list? columns) (not (null? columns)) (andmap label-string? columns)) - (raise-type-error (who->name cwho) "non-empty list of strings (up to 200 characters)" columns)) + (raise-argument-error (who->name cwho) "(non-empty-listof label-string?)" columns)) (when column-order (check-column-order cwho column-order (length columns)))) (private* [check-column-order (lambda (cwho column-order count) (unless (and (list? column-order) - (andmap exact-integer? column-order) - (equal? (sort column-order <) - (for/list ([i (in-range (length column-order))]) i))) - (raise-type-error (who->name cwho) - "#f or list of distinct exact integers from 0 to one less than the list length" - column-order)) + (andmap exact-nonnegative-integer? column-order)) + (raise-argument-error (who->name cwho) + "(listof exact-nonnegative-integer?)" + column-order)) + (unless (equal? (sort column-order <) + (for/list ([i (in-range (length column-order))]) i)) + (raise-arguments-error (who->name cwho) + "bad column-order list;\n not a permutation of integers from 0 to one less than the list length" + "list" column-order)) (unless (= (length column-order) count) - (raise-mismatch-error (who->name cwho) - (format "column count ~a does not match length of column-order list: " - count) - column-order)))] + (raise-arguments-error (who->name cwho) + "column count does not match length of column-order list" + "count" count + "list" column-order)))] [check-column-number (lambda (who i) (unless (exact-nonnegative-integer? i) - (raise-type-error (who->name who) "exact nonnegative integer" i)) + (raise-argument-error (who->name who) "exact-nonnegative-integer?" i)) (unless (i . < . num-columns) - (raise-mismatch-error (who->name who) - (format - "index is too large for ~a-column list box: " - num-columns) - i)))]) + (raise-arguments-error (who->name who) + "given column index is too large" + "given" i + "column count" num-columns)))]) (define column-labels (map string->immutable-string columns)) (define num-columns (length columns)) (define variable-columns? (memq 'variable-columns style)) @@ -790,17 +793,15 @@ (check-dimension who min-size) (check-dimension who max-size) (unless (<= min-size w) - (raise-mismatch-error (who->name who) - (format - "size ~a is less than mininum size: " - w) - min-size)) + (raise-arguments-error (who->name who) + "given size is less than mininum size" + "given" w + "minimum" min-size)) (unless (>= max-size w) - (raise-mismatch-error (who->name who) - (format - "size ~a is less than maximum size: " - w) - max-size))) + (raise-arguments-error (who->name who) + "given size is greater than maximum size" + "given" w + "maximum" max-size))) (send wx set-column-size i w min-size max-size))] [get-column-width (lambda (i) (check-column-number '(method list-box% get-column-width) i) @@ -809,14 +810,16 @@ (let ([who '(method list-box% delete-column)]) (check-column-number who i) (unless variable-columns? - (raise-mismatch-error + (raise-arguments-error (who->name who) - "list box without 'variable-columns style cannot delete column: " - i)) + "cannot delete column;\n list box was created without 'variable-columns style" + "column" i + "list box" this)) (unless (num-columns . > . 1) - (raise-mismatch-error (who->name who) - "cannot delete only column: " - i))) + (raise-arguments-error (who->name who) + "cannot delete column;\n list box has only one column" + "column" i + "list box" this))) (as-entry (lambda () (set! num-columns (sub1 num-columns)) @@ -829,10 +832,11 @@ (let ([who '(method list-box% append-column)]) (check-label-string who label) (unless variable-columns? - (raise-mismatch-error + (raise-arguments-error (who->name who) - "list box without 'variable-columns style cannot add column: " - label))) + "cannot add column;\n list box created without 'variable-columns style" + "list box" this + "new column" label))) (as-entry (lambda () (set! num-columns (add1 num-columns)) @@ -851,22 +855,20 @@ [set (entry-point (lambda (l . more) (let ([cwho '(method list-box% set)]) (unless (= num-columns (+ 1 (length more))) - (raise-mismatch-error (who->name cwho) - (format - "column count ~a doesn't match number of arguments: " - num-columns) - (add1 (length more)))) + (raise-arguments-error (who->name cwho) + "column count doesn't match argument count" + "column count" num-columns + "argument count" (add1 (length more)))) (for ([l (in-list (cons l more))]) (unless (and (list? l) (andmap label-string? l)) - (raise-type-error (who->name cwho) - "list of strings (up to 200 characters)" l))) + (raise-argument-error (who->name cwho) "(listof label-string?)" l))) (for ([more-l (in-list more)]) (unless (= (length more-l) (length l)) - (raise-mismatch-error + (raise-arguments-error (who->name cwho) - (format "first list length ~a does not match length of later argument: " - (length l)) - more-l)))) + "first list length does not match length of later argument" + "first list length" (length l) + "larger argument length" (length more-l))))) (send this -set-list-strings l) (send wx set l . more)))] [set-string (entry-point @@ -875,13 +877,15 @@ (check-non-negative-integer cwho n) ; int error before string (check-label-string cwho d) ; string error before range mismatch (unless (exact-nonnegative-integer? col) - (raise-type-error (who->name cwho) "exact nonnegative integer" col)) + (raise-argument-error (who->name cwho) "exact-nonnegative-integer?" col)) (unless (< -1 col num-columns) - (raise-mismatch-error (who->name cwho) - (format - "column number is not in the list box's allowed range [0, ~a]: " - (sub1 num-columns)) - col))) + (raise-range-error (who->name cwho) + "list box" "column " + col + this + 0 + (sub1 num-columns) + #f))) (check-item 'set-string n) (send this -set-list-string n d) (send wx set-string n d col)))] @@ -902,12 +906,13 @@ (check-non-negative-integer `(method list-box% ,method) n) (let ([m (send wx number)]) (unless (< n m) - (raise-mismatch-error (who->name `(method list-box% ,method)) - (if (zero? m) - "list has no items; given index: " - (format "list has only ~a items, indexed 0 to ~a; given out-of-range index: " - m (sub1 m))) - n)))))]) + (raise-range-error (who->name `(method list-box% ,method)) + "list box" "item " + n + this + 0 + (sub1 m) + #f)))))]) (super-new [mk-wx (lambda () diff --git a/collects/mred/private/mrmenu.rkt b/collects/mred/private/mrmenu.rkt index cf6ce521..4523958c 100644 --- a/collects/mred/private/mrmenu.rkt +++ b/collects/mred/private/mrmenu.rkt @@ -185,7 +185,8 @@ (char? c) (and (symbol? c) (wx:key-symbol-to-menu-key c))) - (raise-type-error (who->name who) "character, key-code symbol, or #f" c))) + ;; FIXME: `key-code-symbol?' is not exported + (raise-argument-error (who->name who) "(or/c char? key-code-symbol? #f)" c))) (define (check-shortcut-prefix who p) (unless (and (list? p) @@ -197,25 +198,28 @@ [(null? p) #t] [(memq (car p) (cdr p)) #f] [else (loop (cdr p))]))) - (raise-type-error (who->name who) - "list of unique symbols: 'shift, 'meta, 'alt, 'cmd, 'option, and 'ctl" - p)) + (raise-arguments-error (who->name who) + (string-append + "bad prefix;\n" + " given prefix is not a list of unique prefix symbols\n" + " allowed symbols: 'shift, 'meta, 'alt, 'cmd, 'option, and 'ctl") + "given prefix" p)) (let ([disallowed (case (system-type) [(unix) '(cmd option)] [(windows) '(cmd option meta)] [(macosx) '(meta alt)])]) (for-each (lambda (i) (when (memq i p) - (raise-mismatch-error (who->name who) - "prefix not supported for the current platform: " - i))) + (raise-arguments-error (who->name who) + "prefix not supported for the current platform" + "prefix" i))) disallowed) (when (eq? 'unix (system-type)) (when (and (memq 'meta p) (memq 'alt p)) - (raise-mismatch-error (who->name who) - "prefix contains both 'meta and 'alt: " - p))))) + (raise-arguments-error (who->name who) + "given prefix contains both 'meta and 'alt" + "given" p))))) (define default-prefix (case (system-type) @@ -414,13 +418,13 @@ (class* mred% (menu-item-container<%>) (init parent [demand-callback void]) (unless (or (is-a? parent frame%) (eq? parent 'root)) - (raise-type-error (constructor-name 'menu-bar) "frame% object or 'root" parent)) + (raise-argument-error (constructor-name 'menu-bar) "(or/c (is-a?/c frame%) 'root)" parent)) (check-callback1 '(constructor menu-bar) demand-callback) (if (eq? parent 'root) (unless (current-eventspace-has-menu-root?) - (raise-mismatch-error (constructor-name 'menu-bar) "no menu bar allowed in the current eventspace for: " parent)) + (raise-arguments-error (constructor-name 'menu-bar) "no 'root menu bar allowed in the current eventspace")) (when (as-entry (lambda () (send (mred->wx parent) get-the-menu-bar))) - (raise-mismatch-error (constructor-name 'menu-bar) "the specified frame already has a menu bar: " parent))) + (raise-arguments-error (constructor-name 'menu-bar) "given frame already has a menu bar" "given" parent))) (define callback demand-callback) (define prnt (if (eq? parent 'root) @@ -428,7 +432,8 @@ (as-entry (lambda () (when root-menu-frame-used? - (raise-mismatch-error (constructor-name 'menu-bar) "already has a menu bar: " parent)) + (raise-arguments-error (constructor-name 'menu-bar) "given parent already has a menu bar" + "given" parent)) (set! root-menu-frame-used? #t))) root-menu-frame) parent)) @@ -455,8 +460,11 @@ (define (menu-parent-only who p) (unless (is-a? p internal-menu<%>) - (raise-type-error (constructor-name who) "parent menu% or popup-menu% object" p))) + (raise-argument-error (constructor-name who) "(or/c (is-a?/c menu%) (is-a?/c popup-menu%))" p))) (define (menu-or-bar-parent who p) (unless (or (is-a? p internal-menu<%>) (is-a? p menu-bar%)) - (raise-type-error (constructor-name who) "built-in menu-item-container<%> object" p))) + (unless (is-a? p menu-item-container<%>) + (raise-arguments-error (constructor-name who) "(is-a?/c menu-item-container<%>)" p)) + (raise-arguments-error (who->name who) "invalid parent;\n given parent is not an instance of a built-in menu item container class" + "given parent" p))) diff --git a/collects/mred/private/mrpanel.rkt b/collects/mred/private/mrpanel.rkt index 8eeb3412..63905849 100644 --- a/collects/mred/private/mrpanel.rkt +++ b/collects/mred/private/mrpanel.rkt @@ -308,7 +308,7 @@ (let ([cwho '(constructor tab-panel)]) (unless (and (list? choices) (andmap label-string? choices)) - (raise-type-error (who->name cwho) "list of strings (up to 200 characters)" choices)) + (raise-argument-error (who->name cwho) "label-string?" choices)) (check-callback cwho callback) (check-container-parent cwho parent) (check-style cwho #f '(deleted no-border) style) @@ -367,8 +367,8 @@ [set (entry-point (lambda (l) (unless (and (list? l) (andmap label-string? l)) - (raise-type-error (who->name '(method tab-panel% set)) - "list of strings (up to 200 characters)" l)) + (raise-argument-error (who->name '(method tab-panel% set)) + "(listof label-string?)" l)) (set! save-choices (map string->immutable-string l)) (send (mred->wx this) set l)))] [get-item-label (entry-point @@ -382,12 +382,13 @@ (check-non-negative-integer `(method tab-panel% ,method) n) (let ([m (length save-choices)]) (unless (< n m) - (raise-mismatch-error (who->name `(method tab-panel% ,method)) - (if (zero? m) - "panel has no tabs; given index: " - (format "panel has only ~a tabs, indexed 0 to ~a; given out-of-range index: " - m (sub1 m))) - n))))]))) + (raise-range-error (who->name `(method tab-panel% ,method)) + "panel" "tab " + n + this + 0 + (sub1 m) + #f))))]))) (define group-box-panel% (class vertical-panel% diff --git a/collects/mred/private/mrtextfield.rkt b/collects/mred/private/mrtextfield.rkt index e514e341..b49b2b8d 100644 --- a/collects/mred/private/mrtextfield.rkt +++ b/collects/mred/private/mrtextfield.rkt @@ -29,7 +29,7 @@ (check-label-string/false cwho label) (when choices? (unless (and (list? choices) (andmap label-string? choices)) - (raise-type-error (who->name cwho) "list of strings (up to 200 characters)" choices))) + (raise-argument-error (who->name cwho) "(listof label-string?)" choices))) (check-container-parent cwho parent) (check-callback cwho callback) (check-string cwho init-value) diff --git a/collects/mred/private/mrtop.rkt b/collects/mred/private/mrtop.rkt index 64859cf5..26bb3820 100644 --- a/collects/mred/private/mrtop.rkt +++ b/collects/mred/private/mrtop.rkt @@ -323,11 +323,11 @@ (define (check-top-level-parent/false who p) (unless (or (not p) (is-a? p frame%) (is-a? p dialog%)) - (raise-type-error (who->name who) "frame% or dialog% object or #f" p))) + (raise-argument-error (who->name who) "(or/c (is-a?/c frame%) (is-a?/c dialog%) #f)" p))) (define (check-frame-parent/false who p) (unless (or (not p) (is-a? p frame%)) - (raise-type-error (who->name who) "frame% object or #f" p))) + (raise-argument-error (who->name who) "(or/c (is-a?/c frame%) #f)" p))) (define root-menu-frame (and (current-eventspace-has-menu-root?) diff --git a/collects/mred/private/mrwindow.rkt b/collects/mred/private/mrwindow.rkt index d3cd5889..fc5a703b 100644 --- a/collects/mred/private/mrwindow.rkt +++ b/collects/mred/private/mrwindow.rkt @@ -148,7 +148,7 @@ #f)] [on-drop-file (lambda (s) (unless (path-string? s) - (raise-type-error (who->name '(method window<%> on-drop-file)) "pathname string" s)))] + (raise-argument-error (who->name '(method window<%> on-drop-file)) "path-string?" s)))] [focus (entry-point (lambda () (send wx set-focus)))] [has-focus? (entry-point (lambda () (send wx has-focus?)))] @@ -212,10 +212,10 @@ (when on? (unless top? (unless (memq wx (send (send wx area-parent) get-children)) - (raise-mismatch-error + (raise-arguments-error (who->name '(method window<%> show)) - "cannot show a subwindow that is not active in its parent: " - this)))) + "cannot show a subwindow that is not active in its parent" + "subwindow" this)))) (send wx show on?)))] [is-shown? (entry-point (lambda () (send wx is-shown?)))] [on-superwindow-show (lambda (visible?) (void))] diff --git a/collects/mred/private/repl.rkt b/collects/mred/private/repl.rkt index a41a3870..9411af00 100644 --- a/collects/mred/private/repl.rkt +++ b/collects/mred/private/repl.rkt @@ -184,7 +184,7 @@ (graphical-read-eval-print-loop esp (not esp))] [(esp override-ports?) (unless (or (not esp) (wx:eventspace? esp)) - (raise-type-error 'graphical-read-eval-print-loop "eventspace or #f" esp)) + (raise-argument-error 'graphical-read-eval-print-loop "(or/c eventspace? #f)" esp)) (-graphical-read-eval-print-loop esp override-ports?)])) (define (textual-read-eval-print-loop) diff --git a/collects/mred/private/snipfile.rkt b/collects/mred/private/snipfile.rkt index d75c43de..8f4c91ee 100644 --- a/collects/mred/private/snipfile.rkt +++ b/collects/mred/private/snipfile.rkt @@ -25,21 +25,19 @@ #:lock-while-reading? [lock-while-reading? #f]) ;; Check arguments: (unless (text . is-a? . text%) - (raise-type-error 'open-input-text-editor "text% object" text)) + (raise-argument-error 'open-input-text-editor "(is-a?/c text%)" text)) (check-non-negative-integer 'open-input-text-editor start) (unless (or (eq? end 'end) (and (integer? end) (exact? end) (not (negative? end)))) - (raise-type-error 'open-input-text-editor "non-negative exact integer or 'end" end)) + (raise-argument-error 'open-input-text-editor "(or/c exact-nonnegative-integer? 'end)" end)) (let ([last (send text last-position)]) (when (start . > . last) - (raise-mismatch-error 'open-input-text-editor - (format "start index outside the range [0,~a]: " last) - start)) + (raise-range-error 'open-input-text-editor "editor" "starting " + start text 0 last #f)) (unless (eq? end 'end) (unless (<= start end last) - (raise-mismatch-error 'open-input-text-editor - (format "end index outside the range [~a,~a]: " start last) - end)))) + (raise-range-error 'open-input-text-editor "editor" "ending " + end text start last 0)))) (let ([end (if (eq? end 'end) (send text last-position) end)] [snip (send text find-snip start 'after-or-none)]) ;; If the region is small enough, and if the editor contains @@ -123,10 +121,10 @@ [next-snip (lambda (to-str) (unless (= revision (grn)) - (raise-mismatch-error + (raise-arguments-error 'text-input-port - "editor has changed since port was opened: " - text)) + "editor has changed since port was opened" + "editor" text)) (set! snip (send-generic snip next-generic)) (update-str-to-snip to-str))] [read-chars (lambda (to-str) diff --git a/collects/mred/private/wxpanel.rkt b/collects/mred/private/wxpanel.rkt index a74122a5..704fa959 100644 --- a/collects/mred/private/wxpanel.rkt +++ b/collects/mred/private/wxpanel.rkt @@ -159,12 +159,12 @@ [add-child (lambda (new-child) (unless (eq? this (send new-child area-parent)) - (raise-mismatch-error 'add-child - "not a child of this container: " - (wx->proxy new-child))) + (raise-arguments-error 'add-child + "subwindow is not a child of this container" + "subwindow" (wx->proxy new-child))) (when (memq new-child children) - (raise-mismatch-error 'add-child "child already active: " - (wx->proxy new-child))) + (raise-arguments-error 'add-child "subwindow area is already active" + "subwindow" (wx->proxy new-child))) (change-children (lambda (l) (append l (list new-child)))))] @@ -180,19 +180,19 @@ (unless (andmap (lambda (child) (eq? this (send child area-parent))) new-children) - (raise-mismatch-error 'change-children - (format + (raise-arguments-error 'change-children (string-append "not all members of the returned list are " - "children of the container ~e; list: ") - (wx->proxy this)) - (map wx->proxy (remq hidden-child new-children)))) + "children of the container") + "container" (wx->proxy this) + "list" (map wx->proxy (remq hidden-child new-children)))) (let loop ([l new-children]) (unless (null? l) (if (memq (car l) (cdr l)) - (raise-mismatch-error 'change-children - "child in the returned list twice: " - (wx->proxy (car l))) + (raise-arguments-error 'change-children + "child appears multiple times in the returned list" + "child" (wx->proxy (car l)) + "list" (map wx->proxy (remq hidden-child new-children))) (loop (cdr l))))) ;; show all new children, hide all deleted children. (let ([added-children (list-diff new-children children)] @@ -202,11 +202,11 @@ child)) removed-children)]) (when non-window - (raise-mismatch-error 'change-children - (format "cannot delete non-window area in ~e: " - (wx->proxy this)) - non-window))) - + (raise-arguments-error 'change-children + "cannot delete non-window area" + "area" non-window + "container" (wx->proxy this)))) + ;; Newly-added children may have been removed when ;; disabled, or now added into a disabled panel: (for-each (lambda (child) (send child queue-active)) @@ -227,9 +227,9 @@ [delete-child (lambda (child) (unless (memq child children) - (raise-mismatch-error 'delete-child - "not a child of this container or child is not active: " - (wx->proxy child))) + (raise-arguments-error 'delete-child + "subwindow is not a child of this container or child is not active" + "subwindow" (wx->proxy child))) (change-children (lambda (child-list) (remq child child-list))))] @@ -372,9 +372,9 @@ (integer? (car x)) (not (negative? (car x))) (exact? (car x)) (integer? (cadr x)) (not (negative? (cadr x))) (exact? (cadr x)))) children-info)) - (raise-type-error (who->name '(method area-container-window<%> place-children)) - "list of (list of non-negative-integer non-negative-integer boolean boolean)" - children-info)) + (raise-argument-error (who->name '(method area-container-window<%> place-children)) + "(listof (list/c exact-nonnegative-integer? exact-nonnegative-integer? any/c any/c))" + children-info)) (check-non-negative-integer '(method area-container-window<%> place-children) width) (check-non-negative-integer '(method area-container-window<%> place-children) height))] [do-place-children @@ -403,9 +403,9 @@ [do-align (lambda (h v set-h set-v) (unless (memq h '(left center right)) - (raise-type-error 'set-alignment "horizontal alignment symbol: left, center, or right" h)) + (raise-argument-error 'set-alignment "(or/c 'left 'center 'right)" h)) (unless (memq v '(top center bottom)) - (raise-type-error 'set-alignment "vertical alignment symbol: top, center, or bottom" v)) + (raise-argument-error 'set-alignment "(or/c 'top 'center 'bottom)" v)) (set-h h) (set-v (case v [(top) 'left] [(center) 'center] [(bottom) 'right])))] [alignment (lambda (h v) @@ -472,9 +472,9 @@ (= 4 (length x)) (andmap (lambda (x) (and (integer? x) (exact? x))) x))) l)) - (raise-mismatch-error 'container-redraw - "result from place-children is not a list of 4-integer lists with the correct length: " - l)) + (raise-arguments-error 'container-redraw + "result from place-children is not a list of 4-integer lists with the correct length" + "result" l)) (panel-redraw children children-info (if hidden-child (cons (list 0 0 width height) (let ([dy (child-info-y-min (car children-info))]) diff --git a/collects/mred/private/wxtop.rkt b/collects/mred/private/wxtop.rkt index 1eb3ee34..494dfe75 100644 --- a/collects/mred/private/wxtop.rkt +++ b/collects/mred/private/wxtop.rkt @@ -32,7 +32,7 @@ (define get-display-size (lambda ([full-screen? #f] #:monitor [monitor 0]) (unless (exact-nonnegative-integer? monitor) - (raise-type-error 'get-display-size "exact non-negative integer" monitor)) + (raise-argument-error 'get-display-size "exact-nonnegative-integer?" monitor)) (let/ec esc (let ([xb (box 0)] [yb (box 0)]) @@ -43,7 +43,7 @@ (define get-display-left-top-inset (lambda ([advisory? #f] #:monitor [monitor 0]) (unless (exact-nonnegative-integer? monitor) - (raise-type-error 'get-display-left-top-inset "exact non-negative integer" monitor)) + (raise-argument-error 'get-display-left-top-inset "exact-nonnegative-integer?" monitor)) (let/ec esc (let ([xb (box 0)] [yb (box 0)])