suzanne.soy/compatibility
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

original commit: 19c33a8e2abba847bb5fa0ad5b7382ce03c583b2
This commit is contained in:
Eli Barzilay 2007-01-17 01:18:50 +00:00
parent eed6ec36e9
commit d9d0f9c8de
10 changed files with 62 additions and 83 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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)

71
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))
(format
"~a: ~a is missing a value name `~a', required by ~a"
who
src-context
(sig-path-name s path)
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))
(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)
(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))
(format
"~a: ~a is missing a sub-unit name `~a', required by ~a"
who
src-context
(sig-path-name (car s) path)
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))
(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)
(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))
(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)
(current-continuation-marks)))))))
#t)))

5
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")))
(format "<procedure-from-consumer-thread>: consumer procedure arity is ~e; provided ~s argument~a"
(procedure-arity f) num (if (= 1 num) "" "s"))
(current-continuation-marks)))))
(semaphore-wait protect)
(set! front-state (cons new-state front-state))

25
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))
(format "compound-unit: unit for tag ~s expects ~a imports, given ~a"
tag
(unit-num-imports unit)
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))
(format "compound-unit: unit for tag ~s has no ~s export"
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)))
(format "invoke-unit: expected a unit with ~a imports, given one with ~a imports"
n (unit-num-imports u))
(current-continuation-marks)))))
;; ----------------------------------------------------------------------

13
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))
(format
"~s: ~a unit imports ~a units, but ~a units were provided"
who tag n c)
(current-continuation-marks))))))
units tags isigs)
(for-each

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

@ -64,10 +64,8 @@
;; 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))
(current-continuation-marks))))
(raise (make-cookie-error (apply format fmt args)
(current-continuation-marks))))
;; The syntax for the Set-Cookie response header is
;; set-cookie = "Set-Cookie:" cookies

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))))

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

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