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

no need for string->immutable-string when creating exceptions

Browse Source 
svn: r5372
This commit is contained in:
Eli Barzilay 2007-01-17 01:18:50 +00:00
parent c194c623c2
commit 19c33a8e2a
53 changed files with 482 additions and 585 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/framework/private/preferences.ss
View File

@ -197,10 +197,9 @@ the state transitions / contracts are:
vs
fail-func)))
(define (raise-unknown-preference-error sym fmt . args)
(raise (exn:make-unknown-preference
(string->immutable-string (string-append (format "~a: " sym) (apply format fmt args)))
(string-append (format "~a: " sym) (apply format fmt args))
(current-continuation-marks))))
;; unmarshall-pref : symbol marshalled -> any

5
collects/games/parcheesi/moves.ss
View File

@ -445,7 +445,6 @@
(define bad-move
(case-lambda
[(str) (raise (make-exn:bad-move (string->immutable-string str)
(current-continuation-marks)))]
[args (raise (make-exn:bad-move (string->immutable-string (apply format args))
[(str) (raise (make-exn:bad-move str (current-continuation-marks)))]
[args (raise (make-exn:bad-move (apply format args)
(current-continuation-marks)))])))

3
collects/handin-client/client.ss
View File

@ -42,8 +42,7 @@
"handin-connect: could not connect to the server (~a:~a)"]
[msg (format msg server port)]
#; ; un-comment to get the full message too
[msg (string-append msg " (" (exn-message e) ")")]
[msg (string->immutable-string msg)])
[msg (string-append msg " (" (exn-message e) ")")])
(raise (make-exn:fail:network msg (exn-continuation-marks e)))))])
(ssl-connect server port ctx)))

10
collects/honu-module/dynamic.ss
View File

@ -576,18 +576,14 @@
(unless tst
(raise
(make-exn:fail:contract
(string->immutable-string
(format "~a: expected ~a value for ~a, got something else: ~e"
(or proc (if (eq? who #t) #f who) "procedure")
type-name
(cond
[(eq? who #t) "result"]
(cond [(eq? who #t) "result"]
[else (if proc
(format "~a argument" who)
(if who
"initialization"
"argument"))])
val))
(if who "initialization" "argument"))])
val)
(current-continuation-marks))))
new-val))

2
collects/htdp/error.ss
View File

@ -18,7 +18,7 @@
(define-struct (tp-exn exn) ())
(define (tp-error name fmt . args)
(raise (make-tp-exn (string->immutable-string (string-append (format "~a: " name) (apply format fmt args)))
(raise (make-tp-exn (string-append (format "~a: " name) (apply format fmt args))
(current-continuation-marks))))
(define (number->ord i)

2
collects/htdp/testing.scm
View File

@ -115,7 +115,7 @@
(define (error-check pred? actual fmt)
(unless (pred? actual)
(raise (make-exn:fail:contract (string->immutable-string (format fmt actual))
(raise (make-exn:fail:contract (format fmt actual)
(current-continuation-marks)))))
;run-and-check: (scheme-val scheme-val scheme-val -> boolean)

10
collects/lang/private/contracts/contracts-helpers.ss
View File

@ -320,18 +320,17 @@ flat-contract : contract
;; generates the correct error report for a define data.
;; the first argument is the define-data contract being checked,
;; the second is the value being checked
;; and the third is the contract (one of the flats that was used in the define-data) that will be
;; reported as the best failure match
;; and the third is the contract (one of the flats that was used in the
;; define-data) that will be reported as the best failure match
(define (define-data-report me value best-cnt)
(with-handlers ([exn:contract-violation?
(lambda (e)
(raise
(make-exn:contract-violation
(string->immutable-string
(format "contract violation: ~e is not a ~e [failed part: ~e]"
value
((contract-hilighter me) '())
((contract-hilighter best-cnt) (exn:contract-violation-path e))))
((contract-hilighter best-cnt) (exn:contract-violation-path e)))
(current-continuation-marks)
value
'()
@ -392,10 +391,9 @@ flat-contract : contract
(opt-lambda (value cnt path [exn-to-pass #f] [message-composer #f])
(let ([cnt-hilighted ((contract-hilighter cnt) path)])
(raise (make-exn:contract-violation
(string->immutable-string
(if message-composer
(format "contract violation: ~a" (message-composer cnt-hilighted))
(format "contract violation: ~e didnt satisfy the contract ~e" value cnt-hilighted)))
(format "contract violation: ~e didnt satisfy the contract ~e" value cnt-hilighted))
(current-continuation-marks)
value
path

6
collects/lang/private/teach.ss
View File

@ -56,8 +56,7 @@
b
(raise
(make-exn:fail:contract
(string->immutable-string
(format "~a: question result is not true or false: ~e" where b))
(format "~a: question result is not true or false: ~e" where b)
(current-continuation-marks)))))
;; Wrapped around uses of local-bound variables:
@ -65,8 +64,7 @@
(if (eq? val undefined)
(raise
(make-exn:fail:contract:variable
(string->immutable-string
(format "local variable used before its definition: ~a" name))
(format "local variable used before its definition: ~a" name)
(current-continuation-marks)
name))
val))

28
collects/lang/private/teachprims.ss
View File

@ -52,10 +52,9 @@
(unless (ok? b)
(raise
(make-exn:fail:contract
(string->immutable-string
(format "~a: second argument must be of type <~a>, given ~e and ~e"
prim-name type
a b))
a b)
(current-continuation-marks))))))
(define check-second
@ -74,7 +73,6 @@
(unless (ok? last)
(raise
(make-exn:fail:contract
(string->immutable-string
(format "~a: last argument must be of type <~a>, given ~e; other args:~a"
prim-name type
last
@ -82,7 +80,7 @@
(let loop ([args args])
(cond
[(null? (cdr args)) null]
[else (cons (car args) (loop (cdr args)))])))))
[else (cons (car args) (loop (cdr args)))]))))
(current-continuation-marks)))))]
[else (loop (cdr l))]))))
@ -97,17 +95,13 @@
(lambda (v which type)
(raise
(make-exn:fail:contract
(string->immutable-string
(format "~a: ~a argument must be of type <~a>, given ~e, ~e, and ~e"
prim-name which type
a b c))
a b c)
(current-continuation-marks))))])
(unless (ok1? a)
(bad a "first" 1type))
(unless (ok2? b)
(bad b "second" 2type))
(unless (ok3? c)
(bad c "third" 3type))))
(unless (ok1? a) (bad a "first" 1type))
(unless (ok2? b) (bad b "second" 2type))
(unless (ok3? c) (bad c "third" 3type))))
(define (positive-real? v)
(and (real? v) (>= v 0)))
@ -117,9 +111,7 @@
(unless (boolean? a)
(raise
(make-exn:fail:contract
(string->immutable-string
(format "not: expected either true or false; given ~e"
a))
(format "not: expected either true or false; given ~e" a)
(current-continuation-marks))))
(not a)))
@ -161,9 +153,8 @@
(string? str))
(raise
(make-exn:fail:contract
(string->immutable-string
(format "error: expected a symbol and a string, got ~e and ~e"
sym str))
sym str)
(current-continuation-marks))))
(error sym "~a" str)))
@ -252,8 +243,7 @@
(define (qcheck quicksort fmt-str . x)
(raise
(make-exn:fail:contract
(string->immutable-string
(string-append (format "~a : " quicksort) (apply format fmt-str x)))
(string-append (format "~a : " quicksort) (apply format fmt-str x))
(current-continuation-marks))))
(define-teach intermediate quicksort

9
collects/make/make-unit.ss
View File

@ -92,8 +92,7 @@
(file-or-directory-modify-seconds s))])
(when (and (make-print-checking)
(or line
(make-print-dep-no-line)))
(or line (make-print-dep-no-line)))
(printf "make: ~achecking ~a~n" indent s)
(flush-output))
@ -134,7 +133,6 @@
(with-handlers ([exn:fail?
(lambda (exn)
(raise (make-exn:fail:make
(string->immutable-string
(format "make: Failed to make ~a; ~a"
(let ([fst (car line)])
(if (pair? fst)
@ -142,7 +140,7 @@
(path-string->string fst)))
(if (exn? exn)
(exn-message exn)
exn)))
exn))
(if (exn? exn)
(exn-continuation-marks exn)
(current-continuation-marks))
@ -150,7 +148,8 @@
exn)))])
((car l))))))))
(unless date
(error 'make "don't know how to make ~a" (path-string->string s))))))])
(error 'make "don't know how to make ~a"
(path-string->string s))))))])
(cond
[(path-string? argv) (make-file argv "")]
[(equal? argv #()) (make-file (caar spec) "")]

6
collects/mrflow/assoc-set-exn.ss
View File

@ -19,16 +19,14 @@
; string assoc-set value -> void
(define (raise-key-not-found-exn fct-name assoc-set key)
(raise (make-exn:assoc-set:key-not-found
(string->immutable-string
(format "~a: key ~a not found in associative set ~a" fct-name key assoc-set))
(format "~a: key ~a not found in associative set ~a" fct-name key assoc-set)
(current-continuation-marks)
assoc-set key)))
; string assoc-set value -> void
(define (raise-duplicate-key-exn fct-name assoc-set key)
(raise (make-exn:assoc-set:duplicate-key
(string->immutable-string
(format "~a: key ~a already in associative set ~a" fct-name key assoc-set))
(format "~a: key ~a already in associative set ~a" fct-name key assoc-set)
(current-continuation-marks)
assoc-set key)))

6
collects/mrflow/set-exn.ss
View File

@ -19,16 +19,14 @@
; string set value -> void
(define (raise-value-not-found-exn fct-name set value)
(raise (make-exn:set:value-not-found
(string->immutable-string
(format "~a: value ~a not found in set ~a" fct-name value set))
(format "~a: value ~a not found in set ~a" fct-name value set)
(current-continuation-marks)
set value)))
; string set value -> void
(define (raise-duplicate-value-exn fct-name set value)
(raise (make-exn:set:duplicate-value
(string->immutable-string
(format "~a: value ~a already in set ~a" fct-name value set))
(format "~a: value ~a already in set ~a" fct-name value set)
(current-continuation-marks)
set value)))

3
collects/mzlib/kw.ss
View File

@ -514,8 +514,7 @@
;; raise an appropriate exception
(define (error* who fmt . args)
(raise (make-exn:fail:contract
(string->immutable-string
(apply format (string-append "~a: " fmt) who args))
(apply format (string-append "~a: " fmt) who args)
(current-continuation-marks))))
;; keyword searching utility (note: no errors for odd length)

6
collects/mzlib/list.ss
View File

@ -238,10 +238,8 @@
[(not (pair? l))
(raise
(make-exn:fail:contract
(string->immutable-string
(format
"~a: second argument must be a (proper) list; given ~e"
'name list))
(format "~a: second argument must be a (proper) list; given ~e"
'name list)
(current-continuation-marks)))]
[else (let ([a (car l)])
#,(case (syntax-e #'mode)

8
collects/mzlib/private/class-internal.ss
View File

@ -3434,12 +3434,8 @@
(define-struct (exn:fail:object exn:fail) () insp)
(define (obj-error where . msg)
(raise
(make-exn:fail:object
(string->immutable-string
(string-append
(format "~a: " where)
(apply format msg)))
(raise (make-exn:fail:object
(string-append (format "~a: " where) (apply format msg))
(current-continuation-marks))))
(define (for-class name)

11
collects/mzlib/private/contract-guts.ss
View File

@ -193,16 +193,11 @@
(define (raise-contract-error val src-info blame contract-sexp fmt . args)
(raise
(make-exn:fail:contract2
(string->immutable-string
((contract-violation->string) val
src-info
blame
contract-sexp
(apply format fmt args)))
((contract-violation->string)
val src-info blame contract-sexp (apply format fmt args))
(current-continuation-marks)
(if src-info
(list (make-srcloc
(syntax-source src-info)
(list (make-srcloc (syntax-source src-info)
(syntax-line src-info)
(syntax-column src-info)
(syntax-position src-info)

4
collects/mzlib/private/match/match-error.ss
View File

@ -10,13 +10,13 @@
((val)
(raise
(make-exn:misc:match
(string->immutable-string (format "match: no matching clause for ~e" val))
(format "match: no matching clause for ~e" val)
(current-continuation-marks)
val)))
((val expr)
(raise
(make-exn:misc:match
(string->immutable-string (format "match: no matching clause for ~e: ~s" val expr))
(format "match: no matching clause for ~e: ~s" val expr)
(current-continuation-marks)
val)))))

15
collects/mzlib/private/sigmatch.ss
View File

@ -46,13 +46,12 @@
(when (eq? v no-val)
(raise
(make-exn:fail:unit
(string->immutable-string
(format
"~a: ~a is missing a value name `~a', required by ~a"
who
src-context
(sig-path-name s path)
dest-context))
dest-context)
(current-continuation-marks))))
(and v
(begin
@ -60,14 +59,13 @@
(let ([p (sig-path-name s path)])
(raise
(make-exn:fail:unit
(string->immutable-string
(format
"~a: ~a contains `~a' as a sub-unit name, but ~a contains `~a' as a value name"
who
src-context
p
dest-context
p))
p)
(current-continuation-marks)))))
(hash-table-put! table s #f)
#t)))]
@ -76,13 +74,12 @@
(when (eq? v no-val)
(raise
(make-exn:fail:unit
(string->immutable-string
(format
"~a: ~a is missing a sub-unit name `~a', required by ~a"
who
src-context
(sig-path-name (car s) path)
dest-context))
dest-context)
(current-continuation-marks))))
(and v
(begin
@ -90,14 +87,13 @@
(let ([p (sig-path-name (car s) path)])
(raise
(make-exn:fail:unit
(string->immutable-string
(format
"~a: ~a contains `~a' as a value name, but ~a contains `~a' as a sub-unit name"
who
src-context
p
dest-context
p))
p)
(current-continuation-marks)))))
(hash-table-put! table (car s) #f)
(check-sig-match v (cdr s) (cons (car s) path)
@ -113,14 +109,13 @@
(let ([p (sig-path-name k path)])
(raise
(make-exn:fail:unit
(string->immutable-string
(format
"~a: ~a contains an extra ~a name `~a' that is not required by ~a"
who
src-context
(if (symbol? v) 'value 'sub-unit)
p
dest-context))
dest-context)
(current-continuation-marks)))))))
#t)))

9
collects/mzlib/private/unit-runtime.ss
View File

@ -42,8 +42,7 @@
(unless (unit? u)
(raise
(make-exn:fail:contract
(string->immutable-string
(format "~a: result of unit expression was not a unit: ~e" name u))
(format "~a: result of unit expression was not a unit: ~e" name u)
(current-continuation-marks)))))
;; check-helper : (vectorof (cons symbol (vectorof (cons symbol symbol)))))
@ -76,7 +75,6 @@
"does not supply")])
(raise
(make-exn:fail:contract
(string->immutable-string
(cond
[(and import? tag)
(format "~a: unit argument expects an import for tag ~a with signature ~a, which this usage context ~a"
@ -99,7 +97,7 @@
(format "~a: this usage context expects a unit with an untagged export with signature ~a, which the given unit ~a"
name
sub-name
err-str)]))
err-str)])
(current-continuation-marks))))))
(loop (sub1 i)))))
@ -113,12 +111,11 @@
(when r
(raise
(make-exn:fail:contract
(string->immutable-string
(if (car dep)
(format "~a: initialization dependent signature ~a with tag ~a is supplied from a later unit with link ~a"
name (car r) (car dep) (cdr r))
(format "~a: untagged initialization dependent signature ~a is supplied from a later unit with link ~a"
name (car r) (cdr r))))
name (car r) (cdr r)))
(current-continuation-marks)))))
(unit-deps unit)))

3
collects/mzlib/thread.ss
View File

@ -46,9 +46,8 @@
(unless (procedure-arity-includes? f num)
(raise
(make-exn:fail:contract:arity
(string->immutable-string
(format "<procedure-from-consumer-thread>: consumer procedure arity is ~e; provided ~s argument~a"
(procedure-arity f) num (if (= 1 num) "" "s")))
(procedure-arity f) num (if (= 1 num) "" "s"))
(current-continuation-marks)))))
(semaphore-wait protect)
(set! front-state (cons new-state front-state))

15
collects/mzlib/unit200.ss
View File

@ -371,17 +371,15 @@
(unless (unit? unit)
(raise
(make-exn:fail:unit
(string->immutable-string
(format "compound-unit: result of expression for tag ~s not a unit: ~e" tag unit))
(format "compound-unit: result of expression for tag ~s not a unit: ~e" tag unit)
(current-continuation-marks))))
(unless (= num-imports (unit-num-imports unit))
(raise
(make-exn:fail:unit
(string->immutable-string
(format "compound-unit: unit for tag ~s expects ~a imports, given ~a"
tag
(unit-num-imports unit)
num-imports))
num-imports)
(current-continuation-marks))))
(list->vector
(map (lambda (ex)
@ -390,9 +388,8 @@
[(null? l)
(raise
(make-exn:fail:unit
(string->immutable-string
(format "compound-unit: unit for tag ~s has no ~s export"
tag ex))
tag ex)
(current-continuation-marks)))]
[(eq? (car l) ex)
i]
@ -757,15 +754,13 @@
(unless (unit? u)
(raise
(make-exn:fail:unit
(string->immutable-string
(format "invoke-unit: result of unit expression was not a unit: ~e" u))
(format "invoke-unit: result of unit expression was not a unit: ~e" u)
(current-continuation-marks))))
(unless (= (unit-num-imports u) n)
(raise
(make-exn:fail:unit
(string->immutable-string
(format "invoke-unit: expected a unit with ~a imports, given one with ~a imports"
n (unit-num-imports u)))
n (unit-num-imports u))
(current-continuation-marks)))))
;; ----------------------------------------------------------------------

9
collects/mzlib/unitsig200.ss
View File

@ -181,10 +181,8 @@
(unless (signed-unit? u)
(raise
(make-exn
(string->immutable-string
(format
"~s: expression for \"~s\" is not a signed unit: ~e"
who tag u))
(format "~s: expression for \"~s\" is not a signed unit: ~e"
who tag u)
(current-continuation-marks)))))
units tags)
(for-each
@ -204,10 +202,9 @@
(unless (= c n)
(raise
(make-exn
(string->immutable-string
(format
"~s: ~a unit imports ~a units, but ~a units were provided"
who tag n c))
who tag n c)
(current-continuation-marks))))))
units tags isigs)
(for-each

4
collects/net/cookie-unit.ss
View File

@ -64,9 +64,7 @@
;; constructs a cookie-error struct from the given error message
;; (added to fix exceptions-must-take-immutable-strings bug)
(define (error* fmt . args)
(raise
(make-cookie-error
(string->immutable-string (apply format fmt args))
(raise (make-cookie-error (apply format fmt args)
(current-continuation-marks))))
;; The syntax for the Set-Cookie response header is

2
collects/net/nntp-unit.ss
View File

@ -38,7 +38,7 @@
(define (signal-error constructor format-string . args)
(lambda exn-args
(raise (apply constructor
(string->immutable-string (apply format format-string args))
(apply format format-string args)
(current-continuation-marks)
exn-args))))

3
collects/net/pop3-unit.ss
View File

@ -32,8 +32,7 @@
(define (signal-error constructor format-string . args)
(lambda exn-args
(raise (apply constructor
(string->immutable-string
(apply format format-string args))
(apply format format-string args)
(current-continuation-marks)
exn-args))))

3
collects/net/tcp-redirect.ss
View File

@ -92,9 +92,8 @@
port
(lambda ()
(raise (make-exn:fail:network
(string->immutable-string
(format "tcp-connect: connection to ~a, port ~a failed (nobody is listening)"
hostname-string port))
hostname-string port)
(current-continuation-marks))))))
(cons to-in to-out))
(values from-in from-out))

9
collects/net/url-unit.ss
View File

@ -60,12 +60,11 @@
v)))))
(define (url-error fmt . args)
(let ([s (string->immutable-string
(raise (make-url-exception
(apply format fmt
(map (lambda (arg)
(if (url? arg) (url->string arg) arg))
args)))])
(raise (make-url-exception s (current-continuation-marks)))))
(map (lambda (arg) (if (url? arg) (url->string arg) arg))
args))
(current-continuation-marks))))
(define (url->string url)
(let ([scheme (url-scheme url)]

3
collects/openssl/mzssl.ss
View File

@ -209,8 +209,7 @@
(define (error/network who fmt . args)
(raise (make-exn:fail:network
(string->immutable-string
(format "~a: ~a" who (apply format fmt args)))
(format "~a: ~a" who (apply format fmt args))
(current-continuation-marks))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

2
collects/planet/planet.ss
View File

@ -115,7 +115,7 @@ PLANNED FEATURES:
;; FEATURE IMPLEMENTATIONS
(define (fail s . args)
(raise (make-exn:fail (string->immutable-string (apply format s args)) (current-continuation-marks))))
(raise (make-exn:fail (apply format s args) (current-continuation-marks))))
(define (download/install owner name majstr minstr)
(let* ([maj (read-from-string majstr)]

6
collects/planet/private/planet-shared.ss
View File

@ -167,18 +167,16 @@ Various common pieces of code that both the client and server need to access
(define (verify-well-formed-hard-link-parameter!)
(unless (and (absolute-path? (HARD-LINK-FILE)) (path-only (HARD-LINK-FILE)))
(raise (make-exn:fail:contract
(string->immutable-string
(format
"The HARD-LINK-FILE setting must be an absolute path name specifying a file; given ~s"
(HARD-LINK-FILE)))
(HARD-LINK-FILE))
(current-continuation-marks)))))
;; get-hard-link-table : -> assoc-table
(define (get-hard-link-table)
(verify-well-formed-hard-link-parameter!)
(if (file-exists? (HARD-LINK-FILE))
(map
(lambda (item) (update-element 4 bytes->path item))
(map (lambda (item) (update-element 4 bytes->path item))
(with-input-from-file (HARD-LINK-FILE) read-all))
'()))

23
collects/planet/resolver.ss
View File

@ -257,15 +257,14 @@ an appropriate subdirectory.
(for-each
(lambda (already-loaded-pkg)
(unless (can-be-loaded-together? pkg already-loaded-pkg)
(raise (make-exn:fail (string->immutable-string
(format
(raise (make-exn:fail (format
"Package ~a loaded twice with multiple incompatible versions:
attempted to load version ~a.~a while version ~a.~a was already loaded"
(pkg-name pkg)
(pkg-maj pkg)
(pkg-min pkg)
(pkg-maj already-loaded-pkg)
(pkg-min already-loaded-pkg)))
(pkg-min already-loaded-pkg))
(current-continuation-marks)))))
loaded-packages)
(hash-table-put! (the-version-cache) (pkg->diamond-key pkg) (cons pkg loaded-packages)))))
@ -303,14 +302,14 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
(raise-syntax-error #f (format "Module path must consist of strings only, received a number (maybe you intended to specify a package version number?): ~s" path) stx)
(raise-syntax-error #f (format "Module path must consist of strings only, received: ~s" path) stx)))
(match-let*
([pspec (pkg-spec->full-pkg-spec pkg-spec stx)]
(match-let* ([pspec (pkg-spec->full-pkg-spec pkg-spec stx)]
[result (get-package module-path pspec)])
(cond
[(string? result)
(raise-syntax-error 'require (string->immutable-string result) stx)]
(cond [(string? result)
(raise-syntax-error 'require result stx)]
[(pkg? result)
(values (apply build-path (pkg-path result) (append path (list file-name))) result)]))]
(values (apply build-path (pkg-path result)
(append path (list file-name)))
result)]))]
[_ (raise-syntax-error 'require (format "Illegal PLaneT invocation: ~e" (cdr spec)) stx)]))
;; PKG-GETTER ::= module-path pspec
@ -515,10 +514,9 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
(define (install-pkg pkg path maj min)
(unless (install?)
(raise (make-exn:fail
(string->immutable-string
(format
"PLaneT error: cannot install package ~s since the install? parameter is set to #f"
(list (car (pkg-spec-path pkg)) (pkg-spec-name pkg) maj min)))
(list (car (pkg-spec-path pkg)) (pkg-spec-name pkg) maj min))
(current-continuation-marks))))
(let* ((owner (car (pkg-spec-path pkg)))
@ -602,8 +600,7 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
[bad-response (state:abort (format "Server returned malformed message: ~e" bad-response))]))
(define (state:abort msg)
(raise (make-exn:i/o:protocol (string->immutable-string msg)
(current-continuation-marks))))
(raise (make-exn:i/o:protocol msg (current-continuation-marks))))
(define (state:failure msg) (list #f msg))
(with-handlers ([void (lambda (e) (close-ports) (raise e))])

6
collects/profj/error-messaging.ss
View File

@ -10,9 +10,9 @@
;make-error: 'a string 'a src -> void
(define (make-error-pass parm)
(lambda (_ message syn-obj src)
(raise (make-exn:fail:syntax (string->immutable-string message)
(current-continuation-marks) (list-immutable (make-so syn-obj src parm))))))
(raise (make-exn:fail:syntax
message (current-continuation-marks)
(list-immutable (make-so syn-obj src parm))))))
;make-so: symbol src (-> location) -> syntax-object
(define (make-so id src parm)

67
collects/profj/libs/java/lang/Object-composite.ss
View File

@ -163,9 +163,9 @@
(let ((val (send wrapped equals-java.lang.Object
(make-object guard-convert-Object obj pos-blame neg-blame src cc-marks))))
(unless (boolean? val)
(raise (make-exn:fail (string->immutable-string
(format "~a broke ~a contract here; Object's equals expects boolean return, given ~a"
pos-blame neg-blame val)) cc-marks)))
(raise (make-exn:fail (format "~a broke ~a contract here; Object's equals expects boolean return, given ~a"
pos-blame neg-blame val)
cc-marks)))
val))
(define/public (finalize) (send wrapped finalize))
@ -174,9 +174,10 @@
(define/public (hashCode)
(let ((val (send wrapped hashCode)))
(unless (integer? val)
(raise (make-exn:fail (string->immutable-string
(raise (make-exn:fail
(format "~a broke ~a contract here; Object's hashCode expects int return, given ~a"
pos-blame neg-blame val)) cc-marks)))
pos-blame neg-blame val)
cc-marks)))
val))
(define/public (notify) (send wrapped notify))
@ -184,9 +185,10 @@
(define/public (toString)
(let ((val (send wrapped toString)))
(unless (string? val)
(raise (make-exn:fail (string->immutable-string
(raise (make-exn:fail
(format "~a broke ~a contract here: Object's toString expects String return, given ~a"
pos-blame neg-blame val)) cc-marks)))
pos-blame neg-blame val)
cc-marks)))
(make-java-string val)))
(define/public (wait) (send wrapped wait))
(define/public (wait-long l) (send wrapped wait-long l))
@ -236,16 +238,16 @@
(define/public (equals-java.lang.Object . obj)
(unless (= (length obj) 1)
(raise (make-exn:fail:contract:arity
(string->immutable-string
(format "~a broke ~a contract here: Object's equals expects to be called with 1 argument, given ~n"
pos-blame neg-blame (length obj))) cc-marks)))
pos-blame neg-blame (length obj))
cc-marks)))
(send wrapped equals-java.lang.Object (wrap-convert-assert-Object (car obj) pos-blame neg-blame src cc-marks)))
(define/public (equals . obj)
(unless (= (length obj) 1)
(raise (make-exn:fail:contract:arity
(string->immutable-string
(format "~a broke ~a contract here: Object's equals expects to be called with 1 argument, given ~n"
pos-blame neg-blame (length obj))) cc-marks)))
pos-blame neg-blame (length obj))
cc-marks)))
(send wrapped equals-java.lang.Object (wrap-convert-assert-Object (car obj) pos-blame neg-blame src cc-marks)))
(define/public (finalize) (send wrapped finalize))
(define/public (getClass) (send wrapped getClass))
@ -262,31 +264,31 @@
(define/public (wait-long . l)
(unless (= (length l) 1)
(raise (make-exn:fail:contract:arity
(string->immutable-string
(format "~a broke ~a contract here: Object's wait-long expects to be called with 1 argument, given ~n"
pos-blame neg-blame (length l))) cc-marks)))
pos-blame neg-blame (length l))
cc-marks)))
(unless (integer? (car l))
(raise (make-exn:fail
(string->immutable-string
(format "~a broke ~a contract here: Object's wait that takes a long argument expected long, given ~a"
pos-blame neg-blame (car l))) cc-marks)))
pos-blame neg-blame (car l))
cc-marks)))
(send wrapped wait-long (car l)))
(define/public (wait-long-int . l)
(unless (= (length l) 2)
(raise (make-exn:fail:contract:arity
(string->immutable-string
(format "~a broke ~a contract here: Object's wait-long-int expects to be called with 2 arguments, given ~n"
pos-blame neg-blame (length l))) cc-marks)))
pos-blame neg-blame (length l))
cc-marks)))
(unless (integer? (car l))
(raise (make-exn:fail
(string->immutable-string
(format "~a broke ~a contract here: Object's wait-long-int expected long, given ~a"
pos-blame neg-blame (car l))) cc-marks)))
pos-blame neg-blame (car l))
cc-marks)))
(unless (integer? (cadr l))
(raise (make-exn:fail
(string->immutable-string
(format "~a broke ~a contract here: Object's wait-long-int expected int, given ~a"
pos-blame neg-blame (cadr l))) cc-marks)))
pos-blame neg-blame (cadr l))
cc-marks)))
(send wrapped wait-long (car l) (cadr l)))
(define/public (my-name) (send wrapped my-name))
(define/public (field-names) (send wrapped field-names))
@ -932,8 +934,7 @@
; -> void
(define/public (printStackTrace)
(print-error-trace (current-output-port)
(make-exn (string->immutable-string message) stack)))
(print-error-trace (current-output-port) (make-exn message stack)))
;These functions do not work correctly yet, and won't until printStreams are implemented
(define/public printStackTrace-PrintStream (lambda (printStream) void))
@ -965,14 +966,14 @@
(define (create-java-exception class msg constructor marks)
(let* ((exn (make-object class))
(str (make-java-string msg))
(scheme-exn (make-java:exception (string->immutable-string msg) marks exn)))
(scheme-exn (make-java:exception msg marks exn)))
(constructor exn str)
(send exn set-exception! scheme-exn)
scheme-exn))
(define (make-runtime-error t)
(create-java-exception
RuntimeException (string->immutable-string t)
RuntimeException t
(lambda (exn str)
(send exn RuntimeException-constructor-java.lang.String
(make-java-string str)))
@ -1031,9 +1032,9 @@
(if (string? val)
(make-java-string val)
(raise (make-exn:fail
(string->immutable-string
(format "~a broke ~a contract here; Throwable's getMessage expects string return, given ~a"
pos-blame neg-blame val)) cc-marks)))))
pos-blame neg-blame val)
cc-marks)))))
(define/public (getCause)
(wrap-convert-assert-Throwable (send wrapped getCause)))
(define/public (getLocalizedMessage)
@ -1041,9 +1042,9 @@
(if (string? val)
(make-java-string val)
(raise (make-exn:fail
(string->immutable-string
(format "~a broke ~a contract here; Throwable's getLocalizedMessage expects string return, given ~a"
pos-blame neg-blame val)) cc-marks)))))
pos-blame neg-blame val)
cc-marks)))))
(define/public (setStackTrace-java.lang.StackTraceElement1 elements)
(send wrapped setStackTrace-java.lang.StackTraceElement1 elements))
(define/public (getStackTrace) (send wrapped getStackTrace))
@ -1073,17 +1074,17 @@
(define/public (initCause-java.lang.Throwable . cse)
(unless (= 1 (length cse))
(raise (make-exn:fail:contract:arity
(string->immutable-string
(format "~a broke ~a contract here: Throwable's initCause expects to be called with 1 argument, given ~n"
pos-blame neg-blame (length cse))) cc-marks)))
pos-blame neg-blame (length cse))
cc-marks)))
(make-object guard-convert-Throwable
(send wrapped initCause-java.lang.Throwable (wrap-convert-assert-Throwable (car cse)))))
(define/public (init-cause . cse)
(unless (= 1 (length cse))
(raise (make-exn:fail:contract:arity
(string->immutable-string
(format "~a broke ~a contract here: Throwable's initCause expects to be called with 1 argument, given ~n"
pos-blame neg-blame (length cse))) cc-marks)))
pos-blame neg-blame (length cse))
cc-marks)))
(make-object guard-convert-Throwable
(send wrapped initCause-java.lang.Throwable (wrap-convert-assert-Throwable (car cse) pos-blame neg-blame src cc-marks))
pos-blame neg-blame src cc-marks))

19
collects/profj/to-scheme.ss
View File

@ -867,9 +867,9 @@
(let ((raise-error
(lambda (method-name num-args)
(raise (make-exn:fail
(string->immutable-string
(format "~a broke the contract with ~a here, expected an object with a method ~a accepting ~a args"
n p method-name num-args)) c)))))
n p method-name num-args)
c)))))
(and ,@(map method->check/error
(filter (lambda (m) (not (eq? 'ctor (method-record-rtype m)))) wrapped-methods))))
#;(c:contract ,(methods->contract (filter (lambda (m) (not (eq? 'ctor (method-record-rtype m))))
@ -940,9 +940,8 @@
`(define/public (,(build-identifier define-name) . args)
(unless (= (length args) ,(length list-of-args))
(raise (make-exn:fail:contract:arity
(string->immutable-string
(format "~a broke the contract with ~a here, method ~a of ~a called with ~a args, instead of ~a"
neg-blame pos-blame ,(method-record-name method) ,(class-name) (length args) ,(length list-of-args)))
neg-blame pos-blame ,(method-record-name method) ,(class-name) (length args) ,(length list-of-args))
cc-marks)))
(let (,@(map (lambda (arg type ref)
`(,arg ,(convert-value (assert-value `(list-ref args ,ref) type #t 'method-arg (method-record-name method)) type #t)))
@ -1011,7 +1010,7 @@
(lambda (ok?)
`(let ((v-1 ,value))
(if (,ok? v-1) v-1
(raise (make-exn:fail (string->immutable-string
(raise (make-exn:fail
,(case kind
((unspecified)
`(format "~a broke the contract with ~a here, type-mismatch expected ~a given ~a"
@ -1025,7 +1024,7 @@
((method-ret)
`(format "~a broke the contract with ~a here, type-mismatch for method return of ~a in ~a: expected ~a given ~a"
neg-blame pos-blame ,name ,(class-name) (quote ,type) v-1)))
) cc-marks)))))))
cc-marks)))))))
(case type
((int byte short long) (check 'integer?))
((float double) (check 'real?))
@ -1811,7 +1810,7 @@
(lambda (expr key src)
(create-syntax #f `(let* ((obj ,expr)
(exn (make-java:exception
(string->immutable-string (send (send obj |getMessage|) get-mzscheme-string))
(send (send obj |getMessage|) get-mzscheme-string)
(current-continuation-marks) obj)))
(send obj set-exception! exn)
(,(create-syntax #f 'raise (build-src key)) exn))
@ -2133,9 +2132,9 @@
`(let ((val ,val))
(if (string? val)
(make-java-string val)
(raise (make-exn:fail (string->immutable-string
(format "~a broke infered contract here: expected String received ~a"
,(class-name) val)) (current-continuation-marks))))))))
(raise (make-exn:fail (format "~a broke infered contract here: expected String received ~a"
,(class-name) val)
(current-continuation-marks))))))))
((unknown-ref? type)
`(let ((val ,val))
(if (string? val)

16
collects/setup/setup-unit.ss
View File

@ -158,17 +158,17 @@
[(owner pkg-name maj-str min-str)
(let ([maj (string->number maj-str)]
[min (string->number min-str)])
(unless maj (error 'setup-plt "Bad major version for PLaneT package: ~s" maj-str))
(unless min (error 'setup-plt "Bad minor version for PLaneT package: ~s" min-str))
(unless maj (error 'setup-plt "Bad major version for PLaneT package: ~e" maj-str))
(unless min (error 'setup-plt "Bad minor version for PLaneT package: ~e" min-str))
(let ([pkg (lookup-package-by-keys owner pkg-name maj min min)])
(if pkg
pkg
(error 'setup-plt "Not an installed PLaneT package: (~s ~s ~s ~s)" owner pkg-name maj min))))]
(error 'setup-plt "Not an installed PLaneT package: (~e ~e ~e ~e)" owner pkg-name maj min))))]
[_ spec]))
(define (planet->cc path owner pkg-file extra-path maj min)
(unless (path? path)
(error 'path->cc "non-path when building package ~a" pkg-file))
(error 'planet->cc "non-path when building package ~e" pkg-file))
(let/ec return
(let* ([info (with-handlers ([exn:fail? (warning-handler #f)])
(get-info/full path))]
@ -176,11 +176,9 @@
(lambda (x)
(when x
(unless (string? x)
(error
(string->immutable-string
(format
"'name' result from directory ~s is not a string:"
path))
(error 'planet->cc
"'name' result from directory ~e is not a string: ~e"
path
x)))))])
(make-cc
#f

4
collects/skipper/debug-tool.ss
View File

@ -597,8 +597,8 @@
(thread (lambda ()
(raise
(make-exn:break
(string->immutable-string
(format "~a (suspending)" (exn-message exn)))
(format "~a (suspending)"
(exn-message exn))
marks
cont))))
(send parent suspend oeh (continuation-mark-set->list marks debug-key) 'break)

3
collects/srfi/14/char-set.ss
View File

@ -156,8 +156,7 @@
(upper . > . #x110000)
(lower . >= . upper))
(raise (make-exn:fail:contract
(string->immutable-string
(format "ucs-range->char-set: invalid range: [~a, ~a)" lower upper))
(format "ucs-range->char-set: invalid range: [~a, ~a)" lower upper)
(current-continuation-marks))))
(char-set-union cs
(cond

3
collects/srfi/43/constructors.ss
View File

@ -149,9 +149,8 @@
(unless (<= start end)
(raise
(make-exn:fail:contract
(string->immutable-string
(format "~a: indices (~a, ~a) out of range for vector: ~a"
'vector-copy start end vec))
'vector-copy start end vec)
(current-continuation-marks))))
(let ((new-vector
(apply make-vector (cons (- end start) fill))))

9
collects/srfi/43/util.ss
View File

@ -54,9 +54,8 @@
(< index (vector-length vec)))
(raise
(make-exn:fail:contract
(string->immutable-string
(format "~a: index ~a out of range for vector: ~a"
callee index vec))
callee index vec)
(current-continuation-marks)))))
@ -71,9 +70,8 @@
(unless (<= 0 index (vector-length vec))
(raise
(make-exn:fail:contract
(string->immutable-string
(format "~a: index ~a out of range for vector: ~a"
callee index vec))
callee index vec)
(current-continuation-marks)))))
;;; (CHECK-INDICES <vector> <start> <end> <caller>) ->
@ -88,9 +86,8 @@
(unless (<= 0 start end (vector-length vec))
(raise
(make-exn:fail:contract
(string->immutable-string
(format "~a: indices (~a, ~a) out of range for vector: ~a"
callee start end vec))
callee start end vec)
(current-continuation-marks)))))
(define (nonneg-int? x)

3
collects/swindle/tiny-clos.ss
View File

@ -130,10 +130,9 @@
(let loop ([fmt-args '()] [args args] [a fmt-num])
(if (zero? a)
(raise (exn-maker
(string->immutable-string
(if sym
(apply format (concat "~s: " fmt) sym (reverse! fmt-args))
(apply format fmt (reverse! fmt-args))))
(apply format fmt (reverse! fmt-args)))
(current-continuation-marks) . args))
(loop (cons (car args) fmt-args) (cdr args) (sub1 a))))))

17
collects/syntax/moddep.ss
View File

@ -30,10 +30,9 @@
(define (raise-wrong-module-name filename expected-name name)
(raise
(make-exn:fail
(string->immutable-string
(format
"load-handler: expected a `module' declaration for `~a' in ~s, found: ~a"
expected-name filename name))
expected-name filename name)
(current-continuation-marks))))
(define (check-module-form exp expected-module filename)
@ -43,10 +42,9 @@
(and filename
(raise
(make-exn:fail
(string->immutable-string
(format
"load-handler: expected a `module' declaration for `~a' in ~s, but found end-of-file"
expected-module filename))
expected-module filename)
(current-continuation-marks))))]
[(compiled-module-expression? (syntax-e exp))
(if (eq? (module-compiled-name (syntax-e exp))
@ -76,10 +74,9 @@
(and filename
(raise
(make-exn:fail
(string->immutable-string
(format
"load-handler: expected a `module' declaration for `~a' in ~s, but found something else"
expected-module filename))
expected-module filename)
(current-continuation-marks))))]))
(define re:suffix #rx#"\\..*$")
@ -172,8 +169,7 @@
(if extension-handler
(extension-handler so #f)
(raise (make-exn:get-module-code
(string->immutable-string
(format "get-module-code: cannot use extension file; ~e" so))
(format "get-module-code: cannot use extension file; ~e" so)
(current-continuation-marks)
so)))]
;; Or maybe even a _loader.so?
@ -189,15 +185,14 @@
(if extension-handler
(extension-handler loader #t)
(raise (make-exn:get-module-code
(string->immutable-string
(format "get-module-code: cannot use _loader file: ~e"
_loader-so))
_loader-so)
(current-continuation-marks)
loader))))]
;; Report a not-there error
[else
(raise (make-exn:get-module-code
(string->immutable-string (format "get-module-code: no such file: ~e" path))
(format "get-module-code: no such file: ~e" path)
(current-continuation-marks)
#f))])))))

6
collects/syntax/readerr.ss
View File

@ -37,17 +37,15 @@
(raise
(make-exn:fail:read
(string->immutable-string
(format "~a~a"
(cond
[(not (error-print-source-location)) ""]
(cond [(not (error-print-source-location)) ""]
[(and line col)
(format "~a:~a:~a: " source-name line col)]
[pos
(format "~a::~a: " source-name pos)]
[else
(format "~a: " source-name)])
msg))
msg)
(current-continuation-marks)
(list-immutable (make-srcloc
source-name line col pos span)))))))

3
collects/tests/mztake/test-harness.ss
View File

@ -20,11 +20,10 @@
[print-struct #t])
(when (or (eq? (print-tests) (first result))
(eq? (print-tests) #t))
(pretty-print result))
(when (and (eq? (print-tests) 'stop)
(eq? (first result) 'bad))
(raise (make-exn:test (string->immutable-string (format "test failed: ~a" result))
(raise (make-exn:test (format "test failed: ~a" result)
(current-continuation-marks))))))

4
collects/web-server/dispatchers/dispatch-passwords.ss
View File

@ -80,8 +80,8 @@
;; exn:password-file is raised.
(define (read-passwords password-path)
(with-handlers ([void (lambda (exn)
(raise (make-exn:password-file (string->immutable-string
(format "could not load password file ~a" password-path))
(raise (make-exn:password-file
(format "could not load password file ~a" password-path)
(current-continuation-marks))))])
(let ([passwords
(let ([raw (load password-path)])

2
collects/web-server/dispatchers/dispatch-servlets.ss
View File

@ -268,7 +268,7 @@
entry)]
[else
(raise (make-exn:fail:filesystem:exists:servlet
(string->immutable-string (format "Couldn't find ~a" servlet-filename))
(format "Couldn't find ~a" servlet-filename)
(current-continuation-marks) ))]))
;; load-servlet/path path -> (or/c #f cache-entry)

9
collects/web-server/managers/lru.ss
View File

@ -45,8 +45,7 @@
(hash-table-get instances instance-id
(lambda ()
(raise (make-exn:fail:servlet-manager:no-instance
(string->immutable-string
(format "No instance for id: ~a" instance-id))
(format "No instance for id: ~a" instance-id)
(current-continuation-marks)
instance-expiration-handler)))))
instance)
@ -95,8 +94,7 @@
(hash-table-get htable a-k-id
(lambda ()
(raise (make-exn:fail:servlet-manager:no-continuation
(string->immutable-string
(format "No continuation for id: ~a" a-k-id))
(format "No continuation for id: ~a" a-k-id)
(current-continuation-marks)
instance-expiration-handler))))
[(list salt k expiration-handler count)
@ -105,8 +103,7 @@
(if (or (not (eq? salt a-salt))
(not k))
(raise (make-exn:fail:servlet-manager:no-continuation
(string->immutable-string
(format "No continuation for id: ~a" a-k-id))
(format "No continuation for id: ~a" a-k-id)
(current-continuation-marks)
(if expiration-handler
expiration-handler

3
collects/web-server/managers/none.ss
View File

@ -18,8 +18,7 @@
(define (instance-lookup instance-id)
(raise (make-exn:fail:servlet-manager:no-instance
(string->immutable-string
(format "No instance for id: ~a" instance-id))
(format "No instance for id: ~a" instance-id)
(current-continuation-marks)
instance-expiration-handler)))

9
collects/web-server/managers/timeouts.ss
View File

@ -50,8 +50,7 @@
(hash-table-get instances instance-id
(lambda ()
(raise (make-exn:fail:servlet-manager:no-instance
(string->immutable-string
(format "No instance for id: ~a" instance-id))
(format "No instance for id: ~a" instance-id)
(current-continuation-marks)
instance-expiration-handler)))))
(increment-timer! (instance-timer instance)
@ -105,8 +104,7 @@
(hash-table-get htable a-k-id
(lambda ()
(raise (make-exn:fail:servlet-manager:no-continuation
(string->immutable-string
(format "No continuation for id: ~a" a-k-id))
(format "No continuation for id: ~a" a-k-id)
(current-continuation-marks)
instance-expiration-handler))))
[(list salt k expiration-handler k-timer)
@ -115,8 +113,7 @@
(if (or (not (eq? salt a-salt))
(not k))
(raise (make-exn:fail:servlet-manager:no-continuation
(string->immutable-string
(format "No continuation for id: ~a" a-k-id))
(format "No continuation for id: ~a" a-k-id)
(current-continuation-marks)
(if expiration-handler
expiration-handler

4
collects/web-server/private/util.ss
View File

@ -41,9 +41,7 @@
;; network-error: symbol string . values -> void
;; throws a formatted exn:fail:network
(define (network-error src fmt . args)
(raise (make-exn:fail:network
(string->immutable-string
(format "~a: ~a" src (apply format fmt args)))
(raise (make-exn:fail:network (format "~a: ~a" src (apply format fmt args))
(current-continuation-marks))))
;; build-path-unless-absolute : path-string? path-string? -> path?

16
collects/xml/private/reader.ss
View File

@ -443,24 +443,18 @@
[offset (location-offset the-pos)])
(raise
(make-exn:xml
(string->immutable-string
(format "read-xml: lex-error: at position ~a: ~a"
(format-source the-pos)
(apply format str rest)))
(apply format str rest))
(current-continuation-marks)
(list-immutable (make-srcloc
(object-name in)
#f
#f
offset
1))))))
(list-immutable
(make-srcloc (object-name in) #f #f offset 1))))))
;; parse-error : (listof srcloc) (listof TST) *-> alpha
;; raises a parsing error, using exn:xml
(define (parse-error src fmt . args)
(raise (make-exn:xml
(string->immutable-string
(apply format (string-append "read-xml: parse-error: " fmt) args))
(raise (make-exn:xml (string-append "read-xml: parse-error: "
(apply format fmt args))
(current-continuation-marks)
src)))

18
collects/xml/private/xexpr.ss
View File

@ -73,20 +73,17 @@
(correct-xexpr? part true false))
(cdr x)))
(false (make-exn:invalid-xexpr
(string->immutable-string
(format
"Expected a symbol as the element name, given ~a"
(car x)))
(car x))
(current-continuation-marks)
x)))))
(else (false
(make-exn:invalid-xexpr
(string->immutable-string
(format
(string-append
(format (string-append
"Expected a string, symbol, number, comment, "
"processing instruction, or list, given ~a")
x))
x)
(current-continuation-marks)
x)))))
@ -111,8 +108,7 @@
(true))
(false
(make-exn:invalid-xexpr
(string->immutable-string
(format "Expected a pair, given ~a" attr))
(format "Expected a pair, given ~a" attr)
(current-continuation-marks)
attr))))))
@ -123,13 +119,11 @@
(if (string? (cadr attr))
(true)
(false (make-exn:invalid-xexpr
(string->immutable-string
(format "Expected a string, given ~a" (cadr attr)))
(format "Expected a string, given ~a" (cadr attr))
(current-continuation-marks)
(cadr attr))))
(false (make-exn:invalid-xexpr
(string->immutable-string
(format "Expected a symbol, given ~a" (car attr)))
(format "Expected a symbol, given ~a" (car attr))
(current-continuation-marks)
(cadr attr)))))