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 vs
fail-func))) fail-func)))
(define (raise-unknown-preference-error sym fmt . args) (define (raise-unknown-preference-error sym fmt . args)
(raise (exn:make-unknown-preference (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)))) (current-continuation-marks))))
;; unmarshall-pref : symbol marshalled -> any ;; unmarshall-pref : symbol marshalled -> any

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

@ -445,7 +445,6 @@
(define bad-move (define bad-move
(case-lambda (case-lambda
[(str) (raise (make-exn:bad-move (string->immutable-string str) [(str) (raise (make-exn:bad-move str (current-continuation-marks)))]
(current-continuation-marks)))] [args (raise (make-exn:bad-move (apply format args)
[args (raise (make-exn:bad-move (string->immutable-string (apply format args))
(current-continuation-marks)))]))) (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)"] "handin-connect: could not connect to the server (~a:~a)"]
[msg (format msg server port)] [msg (format msg server port)]
#; ; un-comment to get the full message too #; ; un-comment to get the full message too
[msg (string-append msg " (" (exn-message e) ")")] [msg (string-append msg " (" (exn-message e) ")")])
[msg (string->immutable-string msg)])
(raise (make-exn:fail:network msg (exn-continuation-marks e)))))]) (raise (make-exn:fail:network msg (exn-continuation-marks e)))))])
(ssl-connect server port ctx))) (ssl-connect server port ctx)))

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

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

2
collects/htdp/error.ss
View File

@ -18,7 +18,7 @@
(define-struct (tp-exn exn) ()) (define-struct (tp-exn exn) ())
(define (tp-error name fmt . args) (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)))) (current-continuation-marks))))
(define (number->ord i) (define (number->ord i)

2
collects/htdp/testing.scm
View File

@ -115,7 +115,7 @@
(define (error-check pred? actual fmt) (define (error-check pred? actual fmt)
(unless (pred? actual) (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))))) (current-continuation-marks)))))
;run-and-check: (scheme-val scheme-val scheme-val -> boolean) ;run-and-check: (scheme-val scheme-val scheme-val -> boolean)

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

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

@ -53,23 +53,21 @@
;; verify-boolean is inserted to check for boolean results: ;; verify-boolean is inserted to check for boolean results:
(define (verify-boolean b where) (define (verify-boolean b where)
(if (or (eq? b #t) (eq? b #f)) (if (or (eq? b #t) (eq? b #f))
b b
(raise (raise
(make-exn:fail:contract (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)))))
(current-continuation-marks)))))
;; Wrapped around uses of local-bound variables: ;; Wrapped around uses of local-bound variables:
(define (check-not-undefined name val) (define (check-not-undefined name val)
(if (eq? val undefined) (if (eq? val undefined)
(raise (raise
(make-exn:fail:contract:variable (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)
(current-continuation-marks) name))
name)) val))
val))
(define undefined (letrec ([x x]) x)) (define undefined (letrec ([x x]) x))
;; Wrapped around top-level definitions to disallow re-definition: ;; Wrapped around top-level definitions to disallow re-definition:

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

@ -51,12 +51,11 @@
(lambda (prim-name a b) (lambda (prim-name a b)
(unless (ok? b) (unless (ok? b)
(raise (raise
(make-exn:fail:contract (make-exn:fail:contract
(string->immutable-string (format "~a: second argument must be of type <~a>, given ~e and ~e"
(format "~a: second argument must be of type <~a>, given ~e and ~e" prim-name type
prim-name type a b)
a b)) (current-continuation-marks))))))
(current-continuation-marks))))))
(define check-second (define check-second
(mk-check-second beginner-list? "list")) (mk-check-second beginner-list? "list"))
@ -73,17 +72,16 @@
(let ([last (car l)]) (let ([last (car l)])
(unless (ok? last) (unless (ok? last)
(raise (raise
(make-exn:fail:contract (make-exn:fail:contract
(string->immutable-string (format "~a: last argument must be of type <~a>, given ~e; other args:~a"
(format "~a: last argument must be of type <~a>, given ~e; other args:~a" prim-name type
prim-name type last
last (build-arg-list
(build-arg-list (let loop ([args args])
(let loop ([args args]) (cond
(cond [(null? (cdr args)) null]
[(null? (cdr args)) null] [else (cons (car args) (loop (cdr args)))]))))
[else (cons (car args) (loop (cdr args)))]))))) (current-continuation-marks)))))]
(current-continuation-marks)))))]
[else (loop (cdr l))])))) [else (loop (cdr l))]))))
(define check-last (define check-last
@ -94,20 +92,16 @@
(define (check-three a b c prim-name ok1? 1type ok2? 2type ok3? 3type) (define (check-three a b c prim-name ok1? 1type ok2? 2type ok3? 3type)
(let ([bad (let ([bad
(lambda (v which type) (lambda (v which type)
(raise (raise
(make-exn:fail:contract (make-exn:fail:contract
(string->immutable-string (format "~a: ~a argument must be of type <~a>, given ~e, ~e, and ~e"
(format "~a: ~a argument must be of type <~a>, given ~e, ~e, and ~e" prim-name which type
prim-name which type a b c)
a b c)) (current-continuation-marks))))])
(current-continuation-marks))))]) (unless (ok1? a) (bad a "first" 1type))
(unless (ok1? a) (unless (ok2? b) (bad b "second" 2type))
(bad a "first" 1type)) (unless (ok3? c) (bad c "third" 3type))))
(unless (ok2? b)
(bad b "second" 2type))
(unless (ok3? c)
(bad c "third" 3type))))
(define (positive-real? v) (define (positive-real? v)
(and (real? v) (>= v 0))) (and (real? v) (>= v 0)))
@ -117,9 +111,7 @@
(unless (boolean? a) (unless (boolean? a)
(raise (raise
(make-exn:fail:contract (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)))) (current-continuation-marks))))
(not a))) (not a)))
@ -160,11 +152,10 @@
(unless (and (symbol? sym) (unless (and (symbol? sym)
(string? str)) (string? str))
(raise (raise
(make-exn:fail:contract (make-exn:fail:contract
(string->immutable-string (format "error: expected a symbol and a string, got ~e and ~e"
(format "error: expected a symbol and a string, got ~e and ~e" sym str)
sym str)) (current-continuation-marks))))
(current-continuation-marks))))
(error sym "~a" str))) (error sym "~a" str)))
(define-teach beginner struct? (define-teach beginner struct?
@ -252,9 +243,8 @@
(define (qcheck quicksort fmt-str . x) (define (qcheck quicksort fmt-str . x)
(raise (raise
(make-exn:fail:contract (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))))
(current-continuation-marks))))
(define-teach intermediate quicksort (define-teach intermediate quicksort
(lambda (l cmp?) (lambda (l cmp?)

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

@ -92,69 +92,68 @@
(file-or-directory-modify-seconds s))]) (file-or-directory-modify-seconds s))])
(when (and (make-print-checking) (when (and (make-print-checking)
(or line (or line (make-print-dep-no-line)))
(make-print-dep-no-line)))
(printf "make: ~achecking ~a~n" indent s) (printf "make: ~achecking ~a~n" indent s)
(flush-output)) (flush-output))
(if line (if line
(let ([deps (cadr line)]) (let ([deps (cadr line)])
(for-each (let ([new-indent (string-append " " indent)]) (for-each (let ([new-indent (string-append " " indent)])
(lambda (d) (make-file d new-indent))) (lambda (d) (make-file d new-indent)))
deps) deps)
(let ([reason (let ([reason
(or (not date) (or (not date)
(ormap (lambda (dep) (ormap (lambda (dep)
(unless (or (file-exists? dep) (unless (or (file-exists? dep)
(directory-exists? dep)) (directory-exists? dep))
(error 'make "dependancy ~a was not made~n" dep)) (error 'make "dependancy ~a was not made~n" dep))
(and (> (file-or-directory-modify-seconds dep) date) (and (> (file-or-directory-modify-seconds dep) date)
dep)) dep))
deps))]) deps))])
(when reason (when reason
(let ([l (cddr line)]) (let ([l (cddr line)])
(unless (null? l) (unless (null? l)
(set! made (cons s made)) (set! made (cons s made))
((make-notify-handler) s) ((make-notify-handler) s)
(printf "make: ~amaking ~a~a~n" (printf "make: ~amaking ~a~a~n"
(if (make-print-checking) indent "") (if (make-print-checking) indent "")
(path-string->string s) (path-string->string s)
(if (make-print-reasons) (if (make-print-reasons)
(cond (cond
[(not date) [(not date)
(string-append " because " (path-string->string s) " does not exist")] (string-append " because " (path-string->string s) " does not exist")]
[(path-string? reason) [(path-string? reason)
(string-append " because " (path-string->string reason) " changed")] (string-append " because " (path-string->string reason) " changed")]
[else [else
(string-append (string-append
(format " because (reason: ~a date: ~a)" (format " because (reason: ~a date: ~a)"
reason date))]) reason date))])
"")) ""))
(flush-output) (flush-output)
(with-handlers ([exn:fail? (with-handlers ([exn:fail?
(lambda (exn) (lambda (exn)
(raise (make-exn:fail:make (raise (make-exn:fail:make
(string->immutable-string (format "make: Failed to make ~a; ~a"
(format "make: Failed to make ~a; ~a" (let ([fst (car line)])
(let ([fst (car line)]) (if (pair? fst)
(if (pair? fst) (map path-string->string fst)
(map path-string->string fst) (path-string->string fst)))
(path-string->string fst))) (if (exn? exn)
(if (exn? exn) (exn-message exn)
(exn-message exn) exn))
exn))) (if (exn? exn)
(if (exn? exn) (exn-continuation-marks exn)
(exn-continuation-marks exn) (current-continuation-marks))
(current-continuation-marks)) (car line)
(car line) exn)))])
exn)))]) ((car l))))))))
((car l)))))))) (unless date
(unless date (error 'make "don't know how to make ~a"
(error 'make "don't know how to make ~a" (path-string->string s))))))]) (path-string->string s))))))])
(cond (cond
[(path-string? argv) (make-file argv "")] [(path-string? argv) (make-file argv "")]
[(equal? argv #()) (make-file (caar spec) "")] [(equal? argv #()) (make-file (caar spec) "")]
[else (for-each (lambda (f) (make-file f "")) (vector->list argv))]) [else (for-each (lambda (f) (make-file f "")) (vector->list argv))])
(for-each (lambda (item) (for-each (lambda (item)
(printf "make: made ~a~n" (path-string->string item))) (printf "make: made ~a~n" (path-string->string item)))

4
collects/mred/private/mritem.ss
View File

@ -65,8 +65,8 @@
((label-checker) ((label-checker)
'(method control<%> set-label) l) '(method control<%> set-label) l)
(let ([l (if (string? l) (let ([l (if (string? l)
(string->immutable-string l) (string->immutable-string l)
l)]) l)])
(send wx set-label l) (send wx set-label l)
(set! label l))))]) (set! label l))))])
(public (public

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

@ -19,16 +19,14 @@
; string assoc-set value -> void ; string assoc-set value -> void
(define (raise-key-not-found-exn fct-name assoc-set key) (define (raise-key-not-found-exn fct-name assoc-set key)
(raise (make-exn:assoc-set:key-not-found (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) (current-continuation-marks)
assoc-set key))) assoc-set key)))
; string assoc-set value -> void ; string assoc-set value -> void
(define (raise-duplicate-key-exn fct-name assoc-set key) (define (raise-duplicate-key-exn fct-name assoc-set key)
(raise (make-exn:assoc-set:duplicate-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) (current-continuation-marks)
assoc-set key))) assoc-set key)))

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

@ -19,16 +19,14 @@
; string set value -> void ; string set value -> void
(define (raise-value-not-found-exn fct-name set value) (define (raise-value-not-found-exn fct-name set value)
(raise (make-exn:set:value-not-found (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) (current-continuation-marks)
set value))) set value)))
; string set value -> void ; string set value -> void
(define (raise-duplicate-value-exn fct-name set value) (define (raise-duplicate-value-exn fct-name set value)
(raise (make-exn:set:duplicate-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) (current-continuation-marks)
set value))) set value)))

3
collects/mzlib/kw.ss
View File

@ -514,8 +514,7 @@
;; raise an appropriate exception ;; raise an appropriate exception
(define (error* who fmt . args) (define (error* who fmt . args)
(raise (make-exn:fail:contract (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)))) (current-continuation-marks))))
;; keyword searching utility (note: no errors for odd length) ;; keyword searching utility (note: no errors for odd length)

6
collects/mzlib/list.ss
View File

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

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

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

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

@ -193,21 +193,16 @@
(define (raise-contract-error val src-info blame contract-sexp fmt . args) (define (raise-contract-error val src-info blame contract-sexp fmt . args)
(raise (raise
(make-exn:fail:contract2 (make-exn:fail:contract2
(string->immutable-string ((contract-violation->string)
((contract-violation->string) val val src-info blame contract-sexp (apply format fmt args))
src-info
blame
contract-sexp
(apply format fmt args)))
(current-continuation-marks) (current-continuation-marks)
(if src-info (if src-info
(list (make-srcloc (list (make-srcloc (syntax-source src-info)
(syntax-source src-info) (syntax-line src-info)
(syntax-line src-info) (syntax-column src-info)
(syntax-column src-info) (syntax-position src-info)
(syntax-position src-info) (syntax-span src-info)))
(syntax-span src-info))) '()))))
'()))))
(define print-contract-liner (define print-contract-liner
(let ([default (pretty-print-print-line)]) (let ([default (pretty-print-print-line)])

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

@ -10,13 +10,13 @@
((val) ((val)
(raise (raise
(make-exn:misc:match (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) (current-continuation-marks)
val))) val)))
((val expr) ((val expr)
(raise (raise
(make-exn:misc:match (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) (current-continuation-marks)
val))))) val)))))

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

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

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

@ -42,8 +42,7 @@
(unless (unit? u) (unless (unit? u)
(raise (raise
(make-exn:fail:contract (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))))) (current-continuation-marks)))))
;; check-helper : (vectorof (cons symbol (vectorof (cons symbol symbol))))) ;; check-helper : (vectorof (cons symbol (vectorof (cons symbol symbol)))))
@ -72,36 +71,35 @@
(let ([tag (if (pair? v0) (car v0) #f)] (let ([tag (if (pair? v0) (car v0) #f)]
[sub-name (car (vector-ref super-sig i))] [sub-name (car (vector-ref super-sig i))]
[err-str (if r [err-str (if r
"supplies multiple times" "supplies multiple times"
"does not supply")]) "does not supply")])
(raise (raise
(make-exn:fail:contract (make-exn:fail:contract
(string->immutable-string (cond
(cond [(and import? tag)
[(and import? tag) (format "~a: unit argument expects an import for tag ~a with signature ~a, which this usage context ~a"
(format "~a: unit argument expects an import for tag ~a with signature ~a, which this usage context ~a" name
name tag
tag sub-name
sub-name err-str)]
err-str)] [import?
[import? (format "~a: unit argument expects an untagged import with signature ~a, which this usage context ~a"
(format "~a: unit argument expects an untagged import with signature ~a, which this usage context ~a" name
name sub-name
sub-name err-str)]
err-str)] [tag
[tag (format "~a: this usage context expects a unit with an export for tag ~a with signature ~a, which the given unit ~a"
(format "~a: this usage context expects a unit with an export for tag ~a with signature ~a, which the given unit ~a" name
name tag
tag sub-name
sub-name err-str)]
err-str)] [else
[else (format "~a: this usage context expects a unit with an untagged export with signature ~a, which the given unit ~a"
(format "~a: this usage context expects a unit with an untagged export with signature ~a, which the given unit ~a" name
name sub-name
sub-name err-str)])
err-str)]))
(current-continuation-marks)))))) (current-continuation-marks))))))
(loop (sub1 i))))) (loop (sub1 i)))))
;; check-deps : (hash-tableof (cons symbol (or symbol #f)) (cons symbol symbol)) unit symbol -> ;; check-deps : (hash-tableof (cons symbol (or symbol #f)) (cons symbol symbol)) unit symbol ->
;; The hash table keys are the tag and runtime signature id ;; The hash table keys are the tag and runtime signature id
@ -113,12 +111,11 @@
(when r (when r
(raise (raise
(make-exn:fail:contract (make-exn:fail:contract
(string->immutable-string (if (car dep)
(if (car dep) (format "~a: initialization dependent signature ~a with tag ~a is supplied from a later unit with link ~a"
(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))
name (car r) (car dep) (cdr r)) (format "~a: untagged initialization dependent signature ~a is supplied from a later unit with link ~a"
(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))))) (current-continuation-marks)))))
(unit-deps unit))) (unit-deps unit)))

5
collects/mzlib/thread.ss
View File

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

25
collects/mzlib/unit200.ss
View File

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

13
collects/mzlib/unitsig200.ss
View File

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

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

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

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

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

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

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

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

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

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

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

3
collects/openssl/mzssl.ss
View File

@ -209,8 +209,7 @@
(define (error/network who fmt . args) (define (error/network who fmt . args)
(raise (make-exn:fail:network (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)))) (current-continuation-marks))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

2
collects/planet/planet.ss
View File

@ -115,7 +115,7 @@ PLANNED FEATURES:
;; FEATURE IMPLEMENTATIONS ;; FEATURE IMPLEMENTATIONS
(define (fail s . args) (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) (define (download/install owner name majstr minstr)
(let* ([maj (read-from-string majstr)] (let* ([maj (read-from-string majstr)]

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

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

41
collects/planet/resolver.ss
View File

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

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

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

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

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

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

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

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

@ -597,8 +597,8 @@
(thread (lambda () (thread (lambda ()
(raise (raise
(make-exn:break (make-exn:break
(string->immutable-string (format "~a (suspending)"
(format "~a (suspending)" (exn-message exn))) (exn-message exn))
marks marks
cont)))) cont))))
(send parent suspend oeh (continuation-mark-set->list marks debug-key) 'break) (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) (upper . > . #x110000)
(lower . >= . upper)) (lower . >= . upper))
(raise (make-exn:fail:contract (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)))) (current-continuation-marks))))
(char-set-union cs (char-set-union cs
(cond (cond

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

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

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

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

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

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

31
collects/syntax/moddep.ss
View File

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

20
collects/syntax/readerr.ss
View File

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

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

@ -20,11 +20,10 @@
[print-struct #t]) [print-struct #t])
(when (or (eq? (print-tests) (first result)) (when (or (eq? (print-tests) (first result))
(eq? (print-tests) #t)) (eq? (print-tests) #t))
(pretty-print result)) (pretty-print result))
(when (and (eq? (print-tests) 'stop) (when (and (eq? (print-tests) 'stop)
(eq? (first result) 'bad)) (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)))))) (current-continuation-marks))))))

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

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

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

@ -268,7 +268,7 @@
entry)] entry)]
[else [else
(raise (make-exn:fail:filesystem:exists:servlet (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) ))])) (current-continuation-marks) ))]))
;; load-servlet/path path -> (or/c #f cache-entry) ;; 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 (hash-table-get instances instance-id
(lambda () (lambda ()
(raise (make-exn:fail:servlet-manager:no-instance (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) (current-continuation-marks)
instance-expiration-handler))))) instance-expiration-handler)))))
instance) instance)
@ -95,8 +94,7 @@
(hash-table-get htable a-k-id (hash-table-get htable a-k-id
(lambda () (lambda ()
(raise (make-exn:fail:servlet-manager:no-continuation (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) (current-continuation-marks)
instance-expiration-handler)))) instance-expiration-handler))))
[(list salt k expiration-handler count) [(list salt k expiration-handler count)
@ -105,8 +103,7 @@
(if (or (not (eq? salt a-salt)) (if (or (not (eq? salt a-salt))
(not k)) (not k))
(raise (make-exn:fail:servlet-manager:no-continuation (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) (current-continuation-marks)
(if expiration-handler (if expiration-handler
expiration-handler expiration-handler

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

@ -18,8 +18,7 @@
(define (instance-lookup instance-id) (define (instance-lookup instance-id)
(raise (make-exn:fail:servlet-manager:no-instance (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) (current-continuation-marks)
instance-expiration-handler))) instance-expiration-handler)))

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

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

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

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

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

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

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

@ -73,22 +73,19 @@
(correct-xexpr? part true false)) (correct-xexpr? part true false))
(cdr x))) (cdr x)))
(false (make-exn:invalid-xexpr (false (make-exn:invalid-xexpr
(string->immutable-string (format
(format "Expected a symbol as the element name, given ~a"
"Expected a symbol as the element name, given ~a" (car x))
(car x))) (current-continuation-marks)
(current-continuation-marks) x)))))
x)))))
(else (false (else (false
(make-exn:invalid-xexpr (make-exn:invalid-xexpr
(string->immutable-string (format (string-append
(format "Expected a string, symbol, number, comment, "
(string-append "processing instruction, or list, given ~a")
"Expected a string, symbol, number, comment, " x)
"processing instruction, or list, given ~a") (current-continuation-marks)
x)) x)))))
(current-continuation-marks)
x)))))
;; has-attribute? : List -> Boolean ;; has-attribute? : List -> Boolean
;; True if the Xexpr provided has an attribute list. ;; True if the Xexpr provided has an attribute list.
@ -111,10 +108,9 @@
(true)) (true))
(false (false
(make-exn:invalid-xexpr (make-exn:invalid-xexpr
(string->immutable-string (format "Expected a pair, given ~a" attr)
(format "Expected a pair, given ~a" attr)) (current-continuation-marks)
(current-continuation-marks) attr))))))
attr))))))
;; attribute-symbol-string? : List (-> a) (exn -> a) -> a ;; attribute-symbol-string? : List (-> a) (exn -> a) -> a
;; True if the list is a list of String,Symbol pairs. ;; True if the list is a list of String,Symbol pairs.
@ -123,15 +119,13 @@
(if (string? (cadr attr)) (if (string? (cadr attr))
(true) (true)
(false (make-exn:invalid-xexpr (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)
(current-continuation-marks) (cadr attr))))
(cadr attr))))
(false (make-exn:invalid-xexpr (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)
(current-continuation-marks) (cadr attr)))))
(cadr attr)))))
;; ; end xexpr? helpers ;; ; end xexpr? helpers
;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;