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

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

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

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