diff --git a/collects/framework/private/preferences.ss b/collects/framework/private/preferences.ss index fb0ed72c01..cb7d82847a 100644 --- a/collects/framework/private/preferences.ss +++ b/collects/framework/private/preferences.ss @@ -196,13 +196,12 @@ the state transitions / contracts are: ps vs fail-func))) - - + (define (raise-unknown-preference-error sym fmt . args) (raise (exn:make-unknown-preference - (string->immutable-string (string-append (format "~a: " sym) (apply format fmt args))) + (string-append (format "~a: " sym) (apply format fmt args)) (current-continuation-marks)))) - + ;; unmarshall-pref : symbol marshalled -> any ;; unmarshalls a preference read from the disk (define (unmarshall-pref p data) diff --git a/collects/games/parcheesi/moves.ss b/collects/games/parcheesi/moves.ss index 4bc1e0bcaa..31e2da4c0d 100644 --- a/collects/games/parcheesi/moves.ss +++ b/collects/games/parcheesi/moves.ss @@ -445,7 +445,6 @@ (define bad-move (case-lambda - [(str) (raise (make-exn:bad-move (string->immutable-string str) - (current-continuation-marks)))] - [args (raise (make-exn:bad-move (string->immutable-string (apply format args)) - (current-continuation-marks)))]))) \ No newline at end of file + [(str) (raise (make-exn:bad-move str (current-continuation-marks)))] + [args (raise (make-exn:bad-move (apply format args) + (current-continuation-marks)))]))) diff --git a/collects/handin-client/client.ss b/collects/handin-client/client.ss index cb6827f8a8..c51daf9bee 100644 --- a/collects/handin-client/client.ss +++ b/collects/handin-client/client.ss @@ -42,8 +42,7 @@ "handin-connect: could not connect to the server (~a:~a)"] [msg (format msg server port)] #; ; un-comment to get the full message too - [msg (string-append msg " (" (exn-message e) ")")] - [msg (string->immutable-string msg)]) + [msg (string-append msg " (" (exn-message e) ")")]) (raise (make-exn:fail:network msg (exn-continuation-marks e)))))]) (ssl-connect server port ctx))) diff --git a/collects/honu-module/dynamic.ss b/collects/honu-module/dynamic.ss index f94638f362..43742694fc 100644 --- a/collects/honu-module/dynamic.ss +++ b/collects/honu-module/dynamic.ss @@ -570,24 +570,20 @@ (syntax-object->datum val-type) (syntax-object->datum target-type)) val-expr))) - + (define (check proc who type-name pred val) (let-values ([(tst new-val) (pred val)]) (unless tst (raise (make-exn:fail:contract - (string->immutable-string - (format "~a: expected ~a value for ~a, got something else: ~e" - (or proc (if (eq? who #t) #f who) "procedure") - type-name - (cond - [(eq? who #t) "result"] - [else (if proc - (format "~a argument" who) - (if who - "initialization" - "argument"))]) - val)) + (format "~a: expected ~a value for ~a, got something else: ~e" + (or proc (if (eq? who #t) #f who) "procedure") + type-name + (cond [(eq? who #t) "result"] + [else (if proc + (format "~a argument" who) + (if who "initialization" "argument"))]) + val) (current-continuation-marks)))) new-val)) diff --git a/collects/htdp/error.ss b/collects/htdp/error.ss index 51a18c875e..f2ce08c388 100644 --- a/collects/htdp/error.ss +++ b/collects/htdp/error.ss @@ -18,7 +18,7 @@ (define-struct (tp-exn exn) ()) (define (tp-error name fmt . args) - (raise (make-tp-exn (string->immutable-string (string-append (format "~a: " name) (apply format fmt args))) + (raise (make-tp-exn (string-append (format "~a: " name) (apply format fmt args)) (current-continuation-marks)))) (define (number->ord i) diff --git a/collects/htdp/testing.scm b/collects/htdp/testing.scm index b785c1ee11..aa3524b1a3 100644 --- a/collects/htdp/testing.scm +++ b/collects/htdp/testing.scm @@ -112,10 +112,10 @@ (let ([test-val (test)]) (make-expected-error src error test-val)))]) (when (check-fail? result) (update-failed-checks result)))) - + (define (error-check pred? actual fmt) (unless (pred? actual) - (raise (make-exn:fail:contract (string->immutable-string (format fmt actual)) + (raise (make-exn:fail:contract (format fmt actual) (current-continuation-marks))))) ;run-and-check: (scheme-val scheme-val scheme-val -> boolean) diff --git a/collects/lang/private/contracts/contracts-helpers.ss b/collects/lang/private/contracts/contracts-helpers.ss index c9b947ba2f..9561a58adc 100644 --- a/collects/lang/private/contracts/contracts-helpers.ss +++ b/collects/lang/private/contracts/contracts-helpers.ss @@ -320,18 +320,17 @@ flat-contract : contract ;; generates the correct error report for a define data. ;; the first argument is the define-data contract being checked, ;; the second is the value being checked - ;; and the third is the contract (one of the flats that was used in the define-data) that will be - ;; reported as the best failure match - (define (define-data-report me value best-cnt) - (with-handlers ([exn:contract-violation? - (lambda (e) - (raise - (make-exn:contract-violation - (string->immutable-string - (format "contract violation: ~e is not a ~e [failed part: ~e]" - value - ((contract-hilighter me) '()) - ((contract-hilighter best-cnt) (exn:contract-violation-path e)))) + ;; and the third is the contract (one of the flats that was used in the + ;; define-data) that will be reported as the best failure match + (define (define-data-report me value best-cnt) + (with-handlers ([exn:contract-violation? + (lambda (e) + (raise + (make-exn:contract-violation + (format "contract violation: ~e is not a ~e [failed part: ~e]" + value + ((contract-hilighter me) '()) + ((contract-hilighter best-cnt) (exn:contract-violation-path e))) (current-continuation-marks) value '() @@ -391,11 +390,10 @@ flat-contract : contract (define contract-error (opt-lambda (value cnt path [exn-to-pass #f] [message-composer #f]) (let ([cnt-hilighted ((contract-hilighter cnt) path)]) - (raise (make-exn:contract-violation - (string->immutable-string - (if message-composer - (format "contract violation: ~a" (message-composer cnt-hilighted)) - (format "contract violation: ~e didnt satisfy the contract ~e" value cnt-hilighted))) + (raise (make-exn:contract-violation + (if message-composer + (format "contract violation: ~a" (message-composer cnt-hilighted)) + (format "contract violation: ~e didnt satisfy the contract ~e" value cnt-hilighted)) (current-continuation-marks) value path diff --git a/collects/lang/private/teach.ss b/collects/lang/private/teach.ss index a0d6df516e..f2400f7779 100644 --- a/collects/lang/private/teach.ss +++ b/collects/lang/private/teach.ss @@ -53,23 +53,21 @@ ;; verify-boolean is inserted to check for boolean results: (define (verify-boolean b where) (if (or (eq? b #t) (eq? b #f)) - b - (raise - (make-exn:fail:contract - (string->immutable-string - (format "~a: question result is not true or false: ~e" where b)) - (current-continuation-marks))))) + b + (raise + (make-exn:fail:contract + (format "~a: question result is not true or false: ~e" where b) + (current-continuation-marks))))) ;; Wrapped around uses of local-bound variables: (define (check-not-undefined name val) (if (eq? val undefined) - (raise - (make-exn:fail:contract:variable - (string->immutable-string - (format "local variable used before its definition: ~a" name)) - (current-continuation-marks) - name)) - val)) + (raise + (make-exn:fail:contract:variable + (format "local variable used before its definition: ~a" name) + (current-continuation-marks) + name)) + val)) (define undefined (letrec ([x x]) x)) ;; Wrapped around top-level definitions to disallow re-definition: diff --git a/collects/lang/private/teachprims.ss b/collects/lang/private/teachprims.ss index a4beb40a03..aa7cbdf2c5 100644 --- a/collects/lang/private/teachprims.ss +++ b/collects/lang/private/teachprims.ss @@ -51,12 +51,11 @@ (lambda (prim-name a b) (unless (ok? b) (raise - (make-exn:fail:contract - (string->immutable-string - (format "~a: second argument must be of type <~a>, given ~e and ~e" - prim-name type - a b)) - (current-continuation-marks)))))) + (make-exn:fail:contract + (format "~a: second argument must be of type <~a>, given ~e and ~e" + prim-name type + a b) + (current-continuation-marks)))))) (define check-second (mk-check-second beginner-list? "list")) @@ -73,20 +72,19 @@ (let ([last (car l)]) (unless (ok? last) (raise - (make-exn:fail:contract - (string->immutable-string - (format "~a: last argument must be of type <~a>, given ~e; other args:~a" - prim-name type - last - (build-arg-list - (let loop ([args args]) - (cond - [(null? (cdr args)) null] - [else (cons (car args) (loop (cdr args)))]))))) - (current-continuation-marks)))))] + (make-exn:fail:contract + (format "~a: last argument must be of type <~a>, given ~e; other args:~a" + prim-name type + last + (build-arg-list + (let loop ([args args]) + (cond + [(null? (cdr args)) null] + [else (cons (car args) (loop (cdr args)))])))) + (current-continuation-marks)))))] [else (loop (cdr l))])))) - (define check-last + (define check-last (mk-check-last beginner-list? "list")) (define check-last/cycle @@ -94,20 +92,16 @@ (define (check-three a b c prim-name ok1? 1type ok2? 2type ok3? 3type) (let ([bad - (lambda (v which type) - (raise - (make-exn:fail:contract - (string->immutable-string - (format "~a: ~a argument must be of type <~a>, given ~e, ~e, and ~e" - prim-name which type - a b c)) - (current-continuation-marks))))]) - (unless (ok1? a) - (bad a "first" 1type)) - (unless (ok2? b) - (bad b "second" 2type)) - (unless (ok3? c) - (bad c "third" 3type)))) + (lambda (v which type) + (raise + (make-exn:fail:contract + (format "~a: ~a argument must be of type <~a>, given ~e, ~e, and ~e" + prim-name which type + a b c) + (current-continuation-marks))))]) + (unless (ok1? a) (bad a "first" 1type)) + (unless (ok2? b) (bad b "second" 2type)) + (unless (ok3? c) (bad c "third" 3type)))) (define (positive-real? v) (and (real? v) (>= v 0))) @@ -117,9 +111,7 @@ (unless (boolean? a) (raise (make-exn:fail:contract - (string->immutable-string - (format "not: expected either true or false; given ~e" - a)) + (format "not: expected either true or false; given ~e" a) (current-continuation-marks)))) (not a))) @@ -160,11 +152,10 @@ (unless (and (symbol? sym) (string? str)) (raise - (make-exn:fail:contract - (string->immutable-string - (format "error: expected a symbol and a string, got ~e and ~e" - sym str)) - (current-continuation-marks)))) + (make-exn:fail:contract + (format "error: expected a symbol and a string, got ~e and ~e" + sym str) + (current-continuation-marks)))) (error sym "~a" str))) (define-teach beginner struct? @@ -252,9 +243,8 @@ (define (qcheck quicksort fmt-str . x) (raise (make-exn:fail:contract - (string->immutable-string - (string-append (format "~a : " quicksort) (apply format fmt-str x))) - (current-continuation-marks)))) + (string-append (format "~a : " quicksort) (apply format fmt-str x)) + (current-continuation-marks)))) (define-teach intermediate quicksort (lambda (l cmp?) diff --git a/collects/make/make-unit.ss b/collects/make/make-unit.ss index 2579f18566..94fcbaba1b 100644 --- a/collects/make/make-unit.ss +++ b/collects/make/make-unit.ss @@ -92,69 +92,68 @@ (file-or-directory-modify-seconds s))]) (when (and (make-print-checking) - (or line - (make-print-dep-no-line))) + (or line (make-print-dep-no-line))) (printf "make: ~achecking ~a~n" indent s) (flush-output)) (if line - (let ([deps (cadr line)]) - (for-each (let ([new-indent (string-append " " indent)]) - (lambda (d) (make-file d new-indent))) - deps) - (let ([reason - (or (not date) - (ormap (lambda (dep) - (unless (or (file-exists? dep) - (directory-exists? dep)) - (error 'make "dependancy ~a was not made~n" dep)) - (and (> (file-or-directory-modify-seconds dep) date) - dep)) - deps))]) - (when reason - (let ([l (cddr line)]) - (unless (null? l) - (set! made (cons s made)) - ((make-notify-handler) s) - (printf "make: ~amaking ~a~a~n" - (if (make-print-checking) indent "") - (path-string->string s) - (if (make-print-reasons) - (cond - [(not date) - (string-append " because " (path-string->string s) " does not exist")] - [(path-string? reason) - (string-append " because " (path-string->string reason) " changed")] - [else - (string-append - (format " because (reason: ~a date: ~a)" - reason date))]) - "")) - (flush-output) - (with-handlers ([exn:fail? - (lambda (exn) - (raise (make-exn:fail:make - (string->immutable-string - (format "make: Failed to make ~a; ~a" - (let ([fst (car line)]) - (if (pair? fst) - (map path-string->string fst) - (path-string->string fst))) - (if (exn? exn) - (exn-message exn) - exn))) - (if (exn? exn) - (exn-continuation-marks exn) - (current-continuation-marks)) - (car line) - exn)))]) - ((car l)))))))) - (unless date - (error 'make "don't know how to make ~a" (path-string->string s))))))]) + (let ([deps (cadr line)]) + (for-each (let ([new-indent (string-append " " indent)]) + (lambda (d) (make-file d new-indent))) + deps) + (let ([reason + (or (not date) + (ormap (lambda (dep) + (unless (or (file-exists? dep) + (directory-exists? dep)) + (error 'make "dependancy ~a was not made~n" dep)) + (and (> (file-or-directory-modify-seconds dep) date) + dep)) + deps))]) + (when reason + (let ([l (cddr line)]) + (unless (null? l) + (set! made (cons s made)) + ((make-notify-handler) s) + (printf "make: ~amaking ~a~a~n" + (if (make-print-checking) indent "") + (path-string->string s) + (if (make-print-reasons) + (cond + [(not date) + (string-append " because " (path-string->string s) " does not exist")] + [(path-string? reason) + (string-append " because " (path-string->string reason) " changed")] + [else + (string-append + (format " because (reason: ~a date: ~a)" + reason date))]) + "")) + (flush-output) + (with-handlers ([exn:fail? + (lambda (exn) + (raise (make-exn:fail:make + (format "make: Failed to make ~a; ~a" + (let ([fst (car line)]) + (if (pair? fst) + (map path-string->string fst) + (path-string->string fst))) + (if (exn? exn) + (exn-message exn) + exn)) + (if (exn? exn) + (exn-continuation-marks exn) + (current-continuation-marks)) + (car line) + exn)))]) + ((car l)))))))) + (unless date + (error 'make "don't know how to make ~a" + (path-string->string s))))))]) (cond - [(path-string? argv) (make-file argv "")] - [(equal? argv #()) (make-file (caar spec) "")] - [else (for-each (lambda (f) (make-file f "")) (vector->list argv))]) + [(path-string? argv) (make-file argv "")] + [(equal? argv #()) (make-file (caar spec) "")] + [else (for-each (lambda (f) (make-file f "")) (vector->list argv))]) (for-each (lambda (item) (printf "make: made ~a~n" (path-string->string item))) diff --git a/collects/mred/private/mritem.ss b/collects/mred/private/mritem.ss index 32f0042fa0..c081792ee8 100644 --- a/collects/mred/private/mritem.ss +++ b/collects/mred/private/mritem.ss @@ -64,9 +64,9 @@ (lambda (l) ((label-checker) '(method control<%> set-label) l) - (let ([l (if (string? l) - (string->immutable-string l) - l)]) + (let ([l (if (string? l) + (string->immutable-string l) + l)]) (send wx set-label l) (set! label l))))]) (public diff --git a/collects/mred/private/mrpanel.ss b/collects/mred/private/mrpanel.ss index 11d327b60f..b54540726f 100644 --- a/collects/mred/private/mrpanel.ss +++ b/collects/mred/private/mrpanel.ss @@ -130,7 +130,7 @@ (public [get-number (lambda () (length save-choices))] [append (entry-point - (lambda (n) + (lambda (n) (check-label-string '(method tab-panel% append) n) (let ([n (string->immutable-string n)]) (set! save-choices (list-append save-choices (list n))) diff --git a/collects/mrflow/assoc-set-exn.ss b/collects/mrflow/assoc-set-exn.ss index aa8ecb44d5..99ded81e80 100644 --- a/collects/mrflow/assoc-set-exn.ss +++ b/collects/mrflow/assoc-set-exn.ss @@ -19,16 +19,14 @@ ; string assoc-set value -> void (define (raise-key-not-found-exn fct-name assoc-set key) (raise (make-exn:assoc-set:key-not-found - (string->immutable-string - (format "~a: key ~a not found in associative set ~a" fct-name key assoc-set)) + (format "~a: key ~a not found in associative set ~a" fct-name key assoc-set) (current-continuation-marks) assoc-set key))) ; string assoc-set value -> void (define (raise-duplicate-key-exn fct-name assoc-set key) (raise (make-exn:assoc-set:duplicate-key - (string->immutable-string - (format "~a: key ~a already in associative set ~a" fct-name key assoc-set)) + (format "~a: key ~a already in associative set ~a" fct-name key assoc-set) (current-continuation-marks) assoc-set key))) diff --git a/collects/mrflow/set-exn.ss b/collects/mrflow/set-exn.ss index 27b064fca5..f13c4e35a7 100644 --- a/collects/mrflow/set-exn.ss +++ b/collects/mrflow/set-exn.ss @@ -19,16 +19,14 @@ ; string set value -> void (define (raise-value-not-found-exn fct-name set value) (raise (make-exn:set:value-not-found - (string->immutable-string - (format "~a: value ~a not found in set ~a" fct-name value set)) + (format "~a: value ~a not found in set ~a" fct-name value set) (current-continuation-marks) set value))) ; string set value -> void (define (raise-duplicate-value-exn fct-name set value) (raise (make-exn:set:duplicate-value - (string->immutable-string - (format "~a: value ~a already in set ~a" fct-name value set)) + (format "~a: value ~a already in set ~a" fct-name value set) (current-continuation-marks) set value))) diff --git a/collects/mzlib/kw.ss b/collects/mzlib/kw.ss index def1f7e80e..81b2e29812 100644 --- a/collects/mzlib/kw.ss +++ b/collects/mzlib/kw.ss @@ -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) diff --git a/collects/mzlib/list.ss b/collects/mzlib/list.ss index f4bd0cefb9..fbad313f93 100644 --- a/collects/mzlib/list.ss +++ b/collects/mzlib/list.ss @@ -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) diff --git a/collects/mzlib/private/class-internal.ss b/collects/mzlib/private/class-internal.ss index 418c0dc991..4cb716644c 100644 --- a/collects/mzlib/private/class-internal.ss +++ b/collects/mzlib/private/class-internal.ss @@ -3430,17 +3430,13 @@ ;;-------------------------------------------------------------------- (define undefined (letrec ([x x]) x)) - + (define-struct (exn:fail:object exn:fail) () insp) (define (obj-error where . msg) - (raise - (make-exn:fail:object - (string->immutable-string - (string-append - (format "~a: " where) - (apply format msg))) - (current-continuation-marks)))) + (raise (make-exn:fail:object + (string-append (format "~a: " where) (apply format msg)) + (current-continuation-marks)))) (define (for-class name) (if name (format " for class: ~a" name) "")) @@ -3448,7 +3444,7 @@ (if name (format " for ~a class: ~a" which name) "")) (define (for-intf name) (if name (format " for interface: ~a" name) "")) - + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; mixin diff --git a/collects/mzlib/private/contract-guts.ss b/collects/mzlib/private/contract-guts.ss index ef82e96bc0..96cf246daf 100644 --- a/collects/mzlib/private/contract-guts.ss +++ b/collects/mzlib/private/contract-guts.ss @@ -193,21 +193,16 @@ (define (raise-contract-error val src-info blame contract-sexp fmt . args) (raise (make-exn:fail:contract2 - (string->immutable-string - ((contract-violation->string) val - src-info - blame - contract-sexp - (apply format fmt args))) + ((contract-violation->string) + val src-info blame contract-sexp (apply format fmt args)) (current-continuation-marks) (if src-info - (list (make-srcloc - (syntax-source src-info) - (syntax-line src-info) - (syntax-column src-info) - (syntax-position src-info) - (syntax-span src-info))) - '())))) + (list (make-srcloc (syntax-source src-info) + (syntax-line src-info) + (syntax-column src-info) + (syntax-position src-info) + (syntax-span src-info))) + '())))) (define print-contract-liner (let ([default (pretty-print-print-line)]) @@ -449,4 +444,4 @@ (define (flat-contract/predicate? pred) (or (flat-contract? pred) (and (procedure? pred) - (procedure-arity-includes? pred 1))))) \ No newline at end of file + (procedure-arity-includes? pred 1))))) diff --git a/collects/mzlib/private/match/match-error.ss b/collects/mzlib/private/match/match-error.ss index 3ae6d5158a..89cf40fb73 100644 --- a/collects/mzlib/private/match/match-error.ss +++ b/collects/mzlib/private/match/match-error.ss @@ -10,13 +10,13 @@ ((val) (raise (make-exn:misc:match - (string->immutable-string (format "match: no matching clause for ~e" val)) + (format "match: no matching clause for ~e" val) (current-continuation-marks) val))) ((val expr) (raise (make-exn:misc:match - (string->immutable-string (format "match: no matching clause for ~e: ~s" val expr)) + (format "match: no matching clause for ~e: ~s" val expr) (current-continuation-marks) val))))) diff --git a/collects/mzlib/private/sigmatch.ss b/collects/mzlib/private/sigmatch.ss index 784a53554b..84d0fc4411 100644 --- a/collects/mzlib/private/sigmatch.ss +++ b/collects/mzlib/private/sigmatch.ss @@ -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))) diff --git a/collects/mzlib/private/unit-runtime.ss b/collects/mzlib/private/unit-runtime.ss index 6b2b32fa6d..3e99c7cf69 100644 --- a/collects/mzlib/private/unit-runtime.ss +++ b/collects/mzlib/private/unit-runtime.ss @@ -42,8 +42,7 @@ (unless (unit? u) (raise (make-exn:fail:contract - (string->immutable-string - (format "~a: result of unit expression was not a unit: ~e" name u)) + (format "~a: result of unit expression was not a unit: ~e" name u) (current-continuation-marks))))) ;; check-helper : (vectorof (cons symbol (vectorof (cons symbol symbol))))) @@ -72,36 +71,35 @@ (let ([tag (if (pair? v0) (car v0) #f)] [sub-name (car (vector-ref super-sig i))] [err-str (if r - "supplies multiple times" - "does not supply")]) + "supplies multiple times" + "does not supply")]) (raise (make-exn:fail:contract - (string->immutable-string - (cond - [(and import? tag) - (format "~a: unit argument expects an import for tag ~a with signature ~a, which this usage context ~a" - name - tag - sub-name - err-str)] - [import? - (format "~a: unit argument expects an untagged import with signature ~a, which this usage context ~a" - name - sub-name - err-str)] - [tag - (format "~a: this usage context expects a unit with an export for tag ~a with signature ~a, which the given unit ~a" - name - tag - sub-name - err-str)] - [else - (format "~a: this usage context expects a unit with an untagged export with signature ~a, which the given unit ~a" - name - sub-name - err-str)])) + (cond + [(and import? tag) + (format "~a: unit argument expects an import for tag ~a with signature ~a, which this usage context ~a" + name + tag + sub-name + err-str)] + [import? + (format "~a: unit argument expects an untagged import with signature ~a, which this usage context ~a" + name + sub-name + err-str)] + [tag + (format "~a: this usage context expects a unit with an export for tag ~a with signature ~a, which the given unit ~a" + name + tag + sub-name + err-str)] + [else + (format "~a: this usage context expects a unit with an untagged export with signature ~a, which the given unit ~a" + name + sub-name + err-str)]) (current-continuation-marks)))))) - (loop (sub1 i))))) + (loop (sub1 i))))) ;; 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 @@ -113,12 +111,11 @@ (when r (raise (make-exn:fail:contract - (string->immutable-string - (if (car dep) - (format "~a: initialization dependent signature ~a with tag ~a is supplied from a later unit with link ~a" - name (car r) (car dep) (cdr r)) - (format "~a: untagged initialization dependent signature ~a is supplied from a later unit with link ~a" - name (car r) (cdr r)))) + (if (car dep) + (format "~a: initialization dependent signature ~a with tag ~a is supplied from a later unit with link ~a" + name (car r) (car dep) (cdr r)) + (format "~a: untagged initialization dependent signature ~a is supplied from a later unit with link ~a" + name (car r) (cdr r))) (current-continuation-marks))))) (unit-deps unit))) diff --git a/collects/mzlib/thread.ss b/collects/mzlib/thread.ss index fa1ad7c7b4..8f717fb292 100644 --- a/collects/mzlib/thread.ss +++ b/collects/mzlib/thread.ss @@ -46,9 +46,8 @@ (unless (procedure-arity-includes? f num) (raise (make-exn:fail:contract:arity - (string->immutable-string - (format ": consumer procedure arity is ~e; provided ~s argument~a" - (procedure-arity f) num (if (= 1 num) "" "s"))) + (format ": 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)) diff --git a/collects/mzlib/unit200.ss b/collects/mzlib/unit200.ss index 0a4733486e..0479eb76f4 100644 --- a/collects/mzlib/unit200.ss +++ b/collects/mzlib/unit200.ss @@ -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))))) ;; ---------------------------------------------------------------------- diff --git a/collects/mzlib/unitsig200.ss b/collects/mzlib/unitsig200.ss index 551b0d1a3e..f0a744b663 100644 --- a/collects/mzlib/unitsig200.ss +++ b/collects/mzlib/unitsig200.ss @@ -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 diff --git a/collects/net/cookie-unit.ss b/collects/net/cookie-unit.ss index 8b5317e331..dd2d5ac70c 100644 --- a/collects/net/cookie-unit.ss +++ b/collects/net/cookie-unit.ss @@ -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 diff --git a/collects/net/nntp-unit.ss b/collects/net/nntp-unit.ss index aac80a1107..e07fa81165 100644 --- a/collects/net/nntp-unit.ss +++ b/collects/net/nntp-unit.ss @@ -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)))) diff --git a/collects/net/pop3-unit.ss b/collects/net/pop3-unit.ss index 2e9ce64459..d0b754c8b7 100644 --- a/collects/net/pop3-unit.ss +++ b/collects/net/pop3-unit.ss @@ -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)))) diff --git a/collects/net/tcp-redirect.ss b/collects/net/tcp-redirect.ss index c88828df94..717aa60e1c 100644 --- a/collects/net/tcp-redirect.ss +++ b/collects/net/tcp-redirect.ss @@ -92,9 +92,8 @@ port (lambda () (raise (make-exn:fail:network - (string->immutable-string - (format "tcp-connect: connection to ~a, port ~a failed (nobody is listening)" - hostname-string port)) + (format "tcp-connect: connection to ~a, port ~a failed (nobody is listening)" + hostname-string port) (current-continuation-marks)))))) (cons to-in to-out)) (values from-in from-out)) diff --git a/collects/net/url-unit.ss b/collects/net/url-unit.ss index 8b3fc4d024..34603a0135 100644 --- a/collects/net/url-unit.ss +++ b/collects/net/url-unit.ss @@ -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)] diff --git a/collects/openssl/mzssl.ss b/collects/openssl/mzssl.ss index 891b52384e..41e01aec2a 100644 --- a/collects/openssl/mzssl.ss +++ b/collects/openssl/mzssl.ss @@ -209,8 +209,7 @@ (define (error/network who fmt . args) (raise (make-exn:fail:network - (string->immutable-string - (format "~a: ~a" who (apply format fmt args))) + (format "~a: ~a" who (apply format fmt args)) (current-continuation-marks)))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/collects/planet/planet.ss b/collects/planet/planet.ss index 3a14067711..9b0bd811df 100644 --- a/collects/planet/planet.ss +++ b/collects/planet/planet.ss @@ -114,8 +114,8 @@ PLANNED FEATURES: ;; ============================================================ ;; FEATURE IMPLEMENTATIONS - (define (fail s . args) - (raise (make-exn:fail (string->immutable-string (apply format s args)) (current-continuation-marks)))) + (define (fail s . args) + (raise (make-exn:fail (apply format s args) (current-continuation-marks)))) (define (download/install owner name majstr minstr) (let* ([maj (read-from-string majstr)] diff --git a/collects/planet/private/planet-shared.ss b/collects/planet/private/planet-shared.ss index 084fae7bec..f2a1c085b1 100644 --- a/collects/planet/private/planet-shared.ss +++ b/collects/planet/private/planet-shared.ss @@ -161,25 +161,23 @@ Various common pieces of code that both the client and server need to access (and (equal? (assoc-table-row->name row) (pkg-spec-name pkg)) (equal? (assoc-table-row->path row) (pkg-spec-path pkg)))) (get-hard-link-table))) - + ;; verify-well-formed-hard-link-parameter! : -> void ;; pitches a fit if the hard link table parameter isn't set right (define (verify-well-formed-hard-link-parameter!) (unless (and (absolute-path? (HARD-LINK-FILE)) (path-only (HARD-LINK-FILE))) - (raise (make-exn:fail:contract - (string->immutable-string - (format - "The HARD-LINK-FILE setting must be an absolute path name specifying a file; given ~s" - (HARD-LINK-FILE))) + (raise (make-exn:fail:contract + (format + "The HARD-LINK-FILE setting must be an absolute path name specifying a file; given ~s" + (HARD-LINK-FILE)) (current-continuation-marks))))) - + ;; get-hard-link-table : -> assoc-table (define (get-hard-link-table) (verify-well-formed-hard-link-parameter!) (if (file-exists? (HARD-LINK-FILE)) - (map - (lambda (item) (update-element 4 bytes->path item)) - (with-input-from-file (HARD-LINK-FILE) read-all)) + (map (lambda (item) (update-element 4 bytes->path item)) + (with-input-from-file (HARD-LINK-FILE) read-all)) '())) ;; row-for-package? : row string (listof string) num num -> boolean diff --git a/collects/planet/resolver.ss b/collects/planet/resolver.ss index 6258dd8db6..f57cd18081 100644 --- a/collects/planet/resolver.ss +++ b/collects/planet/resolver.ss @@ -257,15 +257,14 @@ an appropriate subdirectory. (for-each (lambda (already-loaded-pkg) (unless (can-be-loaded-together? pkg already-loaded-pkg) - (raise (make-exn:fail (string->immutable-string - (format - "Package ~a loaded twice with multiple incompatible versions: -attempted to load version ~a.~a while version ~a.~a was already loaded" - (pkg-name pkg) - (pkg-maj pkg) - (pkg-min pkg) - (pkg-maj already-loaded-pkg) - (pkg-min already-loaded-pkg))) + (raise (make-exn:fail (format + "Package ~a loaded twice with multiple incompatible versions: +attempted to load version ~a.~a while version ~a.~a was already loaded" + (pkg-name pkg) + (pkg-maj pkg) + (pkg-min pkg) + (pkg-maj already-loaded-pkg) + (pkg-min already-loaded-pkg)) (current-continuation-marks))))) loaded-packages) (hash-table-put! (the-version-cache) (pkg->diamond-key pkg) (cons pkg loaded-packages))))) @@ -302,15 +301,15 @@ attempted to load version ~a.~a while version ~a.~a was already loaded" (if (ormap number? path) (raise-syntax-error #f (format "Module path must consist of strings only, received a number (maybe you intended to specify a package version number?): ~s" path) stx) (raise-syntax-error #f (format "Module path must consist of strings only, received: ~s" path) stx))) - - (match-let* - ([pspec (pkg-spec->full-pkg-spec pkg-spec stx)] - [result (get-package module-path pspec)]) - (cond - [(string? result) - (raise-syntax-error 'require (string->immutable-string result) stx)] - [(pkg? result) - (values (apply build-path (pkg-path result) (append path (list file-name))) result)]))] + + (match-let* ([pspec (pkg-spec->full-pkg-spec pkg-spec stx)] + [result (get-package module-path pspec)]) + (cond [(string? result) + (raise-syntax-error 'require result stx)] + [(pkg? result) + (values (apply build-path (pkg-path result) + (append path (list file-name))) + result)]))] [_ (raise-syntax-error 'require (format "Illegal PLaneT invocation: ~e" (cdr spec)) stx)])) ;; PKG-GETTER ::= module-path pspec @@ -514,13 +513,12 @@ attempted to load version ~a.~a while version ~a.~a was already loaded" ; install the given pkg to the planet cache and return a PKG representing the installed file (define (install-pkg pkg path maj min) (unless (install?) - (raise (make-exn:fail - (string->immutable-string - (format - "PLaneT error: cannot install package ~s since the install? parameter is set to #f" - (list (car (pkg-spec-path pkg)) (pkg-spec-name pkg) maj min))) + (raise (make-exn:fail + (format + "PLaneT error: cannot install package ~s since the install? parameter is set to #f" + (list (car (pkg-spec-path pkg)) (pkg-spec-name pkg) maj min)) (current-continuation-marks)))) - + (let* ((owner (car (pkg-spec-path pkg))) (extra-path (cdr (pkg-spec-path pkg))) (the-dir @@ -601,9 +599,8 @@ attempted to load version ~a.~a while version ~a.~a was already loaded" (state:abort (format "Unknown error ~a receiving package: ~a" code msg))] [bad-response (state:abort (format "Server returned malformed message: ~e" bad-response))])) - (define (state:abort msg) - (raise (make-exn:i/o:protocol (string->immutable-string msg) - (current-continuation-marks)))) + (define (state:abort msg) + (raise (make-exn:i/o:protocol msg (current-continuation-marks)))) (define (state:failure msg) (list #f msg)) (with-handlers ([void (lambda (e) (close-ports) (raise e))]) diff --git a/collects/profj/error-messaging.ss b/collects/profj/error-messaging.ss index 9fffb5312c..2ea422a719 100644 --- a/collects/profj/error-messaging.ss +++ b/collects/profj/error-messaging.ss @@ -10,10 +10,10 @@ ;make-error: 'a string 'a src -> void (define (make-error-pass parm) (lambda (_ message syn-obj src) - (raise (make-exn:fail:syntax (string->immutable-string message) - (current-continuation-marks) (list-immutable (make-so syn-obj src parm)))))) - - + (raise (make-exn:fail:syntax + message (current-continuation-marks) + (list-immutable (make-so syn-obj src parm)))))) + ;make-so: symbol src (-> location) -> syntax-object (define (make-so id src parm) (datum->syntax-object #f id (build-src-list src parm))) @@ -112,4 +112,4 @@ (special-name-name method) (id-string method))))))) - ) \ No newline at end of file + ) diff --git a/collects/profj/libs/java/lang/Object-composite.ss b/collects/profj/libs/java/lang/Object-composite.ss index 9088913040..252a597605 100644 --- a/collects/profj/libs/java/lang/Object-composite.ss +++ b/collects/profj/libs/java/lang/Object-composite.ss @@ -163,9 +163,9 @@ (let ((val (send wrapped equals-java.lang.Object (make-object guard-convert-Object obj pos-blame neg-blame src cc-marks)))) (unless (boolean? val) - (raise (make-exn:fail (string->immutable-string - (format "~a broke ~a contract here; Object's equals expects boolean return, given ~a" - pos-blame neg-blame val)) cc-marks))) + (raise (make-exn:fail (format "~a broke ~a contract here; Object's equals expects boolean return, given ~a" + pos-blame neg-blame val) + cc-marks))) val)) (define/public (finalize) (send wrapped finalize)) @@ -174,9 +174,10 @@ (define/public (hashCode) (let ((val (send wrapped hashCode))) (unless (integer? val) - (raise (make-exn:fail (string->immutable-string - (format "~a broke ~a contract here; Object's hashCode expects int return, given ~a" - pos-blame neg-blame val)) cc-marks))) + (raise (make-exn:fail + (format "~a broke ~a contract here; Object's hashCode expects int return, given ~a" + pos-blame neg-blame val) + cc-marks))) val)) (define/public (notify) (send wrapped notify)) @@ -184,9 +185,10 @@ (define/public (toString) (let ((val (send wrapped toString))) (unless (string? val) - (raise (make-exn:fail (string->immutable-string - (format "~a broke ~a contract here: Object's toString expects String return, given ~a" - pos-blame neg-blame val)) cc-marks))) + (raise (make-exn:fail + (format "~a broke ~a contract here: Object's toString expects String return, given ~a" + pos-blame neg-blame val) + cc-marks))) (make-java-string val))) (define/public (wait) (send wrapped wait)) (define/public (wait-long l) (send wrapped wait-long l)) @@ -236,16 +238,16 @@ (define/public (equals-java.lang.Object . obj) (unless (= (length obj) 1) (raise (make-exn:fail:contract:arity - (string->immutable-string - (format "~a broke ~a contract here: Object's equals expects to be called with 1 argument, given ~n" - pos-blame neg-blame (length obj))) cc-marks))) + (format "~a broke ~a contract here: Object's equals expects to be called with 1 argument, given ~n" + pos-blame neg-blame (length obj)) + cc-marks))) (send wrapped equals-java.lang.Object (wrap-convert-assert-Object (car obj) pos-blame neg-blame src cc-marks))) (define/public (equals . obj) (unless (= (length obj) 1) (raise (make-exn:fail:contract:arity - (string->immutable-string - (format "~a broke ~a contract here: Object's equals expects to be called with 1 argument, given ~n" - pos-blame neg-blame (length obj))) cc-marks))) + (format "~a broke ~a contract here: Object's equals expects to be called with 1 argument, given ~n" + pos-blame neg-blame (length obj)) + cc-marks))) (send wrapped equals-java.lang.Object (wrap-convert-assert-Object (car obj) pos-blame neg-blame src cc-marks))) (define/public (finalize) (send wrapped finalize)) (define/public (getClass) (send wrapped getClass)) @@ -262,35 +264,35 @@ (define/public (wait-long . l) (unless (= (length l) 1) (raise (make-exn:fail:contract:arity - (string->immutable-string - (format "~a broke ~a contract here: Object's wait-long expects to be called with 1 argument, given ~n" - pos-blame neg-blame (length l))) cc-marks))) + (format "~a broke ~a contract here: Object's wait-long expects to be called with 1 argument, given ~n" + pos-blame neg-blame (length l)) + cc-marks))) (unless (integer? (car l)) - (raise (make-exn:fail - (string->immutable-string - (format "~a broke ~a contract here: Object's wait that takes a long argument expected long, given ~a" - pos-blame neg-blame (car l))) cc-marks))) + (raise (make-exn:fail + (format "~a broke ~a contract here: Object's wait that takes a long argument expected long, given ~a" + pos-blame neg-blame (car l)) + cc-marks))) (send wrapped wait-long (car l))) (define/public (wait-long-int . l) (unless (= (length l) 2) (raise (make-exn:fail:contract:arity - (string->immutable-string - (format "~a broke ~a contract here: Object's wait-long-int expects to be called with 2 arguments, given ~n" - pos-blame neg-blame (length l))) cc-marks))) + (format "~a broke ~a contract here: Object's wait-long-int expects to be called with 2 arguments, given ~n" + pos-blame neg-blame (length l)) + cc-marks))) (unless (integer? (car l)) - (raise (make-exn:fail - (string->immutable-string - (format "~a broke ~a contract here: Object's wait-long-int expected long, given ~a" - pos-blame neg-blame (car l))) cc-marks))) + (raise (make-exn:fail + (format "~a broke ~a contract here: Object's wait-long-int expected long, given ~a" + pos-blame neg-blame (car l)) + cc-marks))) (unless (integer? (cadr l)) - (raise (make-exn:fail - (string->immutable-string - (format "~a broke ~a contract here: Object's wait-long-int expected int, given ~a" - pos-blame neg-blame (cadr l))) cc-marks))) + (raise (make-exn:fail + (format "~a broke ~a contract here: Object's wait-long-int expected int, given ~a" + pos-blame neg-blame (cadr l)) + cc-marks))) (send wrapped wait-long (car l) (cadr l))) (define/public (my-name) (send wrapped my-name)) (define/public (field-names) (send wrapped field-names)) - (define/public (field-values) (send wrapped field-values)) + (define/public (field-values) (send wrapped field-values)) (define/public (fields-for-display) (send wrapped fields-for-display)) (super-instantiate ()))) @@ -929,11 +931,10 @@ (make-java-string (format "~a: ~a" (send this my-name) (send (send this getMessage) get-mzscheme-string))))) - + ; -> void (define/public (printStackTrace) - (print-error-trace (current-output-port) - (make-exn (string->immutable-string message) stack))) + (print-error-trace (current-output-port) (make-exn message stack))) ;These functions do not work correctly yet, and won't until printStreams are implemented (define/public printStackTrace-PrintStream (lambda (printStream) void)) @@ -965,14 +966,14 @@ (define (create-java-exception class msg constructor marks) (let* ((exn (make-object class)) (str (make-java-string msg)) - (scheme-exn (make-java:exception (string->immutable-string msg) marks exn))) + (scheme-exn (make-java:exception msg marks exn))) (constructor exn str) (send exn set-exception! scheme-exn) scheme-exn)) - + (define (make-runtime-error t) - (create-java-exception - RuntimeException (string->immutable-string t) + (create-java-exception + RuntimeException t (lambda (exn str) (send exn RuntimeException-constructor-java.lang.String (make-java-string str))) @@ -1030,20 +1031,20 @@ (let ((val (send wrapped getMessage))) (if (string? val) (make-java-string val) - (raise (make-exn:fail - (string->immutable-string - (format "~a broke ~a contract here; Throwable's getMessage expects string return, given ~a" - pos-blame neg-blame val)) cc-marks))))) - (define/public (getCause) - (wrap-convert-assert-Throwable (send wrapped getCause))) - (define/public (getLocalizedMessage) + (raise (make-exn:fail + (format "~a broke ~a contract here; Throwable's getMessage expects string return, given ~a" + pos-blame neg-blame val) + cc-marks))))) + (define/public (getCause) + (wrap-convert-assert-Throwable (send wrapped getCause))) + (define/public (getLocalizedMessage) (let ((val (send wrapped getLocalizedMessage))) (if (string? val) (make-java-string val) - (raise (make-exn:fail - (string->immutable-string - (format "~a broke ~a contract here; Throwable's getLocalizedMessage expects string return, given ~a" - pos-blame neg-blame val)) cc-marks))))) + (raise (make-exn:fail + (format "~a broke ~a contract here; Throwable's getLocalizedMessage expects string return, given ~a" + pos-blame neg-blame val) + cc-marks))))) (define/public (setStackTrace-java.lang.StackTraceElement1 elements) (send wrapped setStackTrace-java.lang.StackTraceElement1 elements)) (define/public (getStackTrace) (send wrapped getStackTrace)) @@ -1073,17 +1074,17 @@ (define/public (initCause-java.lang.Throwable . cse) (unless (= 1 (length cse)) (raise (make-exn:fail:contract:arity - (string->immutable-string - (format "~a broke ~a contract here: Throwable's initCause expects to be called with 1 argument, given ~n" - pos-blame neg-blame (length cse))) cc-marks))) + (format "~a broke ~a contract here: Throwable's initCause expects to be called with 1 argument, given ~n" + pos-blame neg-blame (length cse)) + cc-marks))) (make-object guard-convert-Throwable (send wrapped initCause-java.lang.Throwable (wrap-convert-assert-Throwable (car cse))))) (define/public (init-cause . cse) (unless (= 1 (length cse)) (raise (make-exn:fail:contract:arity - (string->immutable-string - (format "~a broke ~a contract here: Throwable's initCause expects to be called with 1 argument, given ~n" - pos-blame neg-blame (length cse))) cc-marks))) + (format "~a broke ~a contract here: Throwable's initCause expects to be called with 1 argument, given ~n" + pos-blame neg-blame (length cse)) + cc-marks))) (make-object guard-convert-Throwable (send wrapped initCause-java.lang.Throwable (wrap-convert-assert-Throwable (car cse) pos-blame neg-blame src cc-marks)) pos-blame neg-blame src cc-marks)) @@ -1120,4 +1121,4 @@ (compile-rest-of-lang (list "Object" "Throwable" "String" "Exception" "RuntimeException" "Comparable")) - ) \ No newline at end of file + ) diff --git a/collects/profj/to-scheme.ss b/collects/profj/to-scheme.ss index 35b1c11193..d4330bad1a 100644 --- a/collects/profj/to-scheme.ss +++ b/collects/profj/to-scheme.ss @@ -864,12 +864,12 @@ (dynamic-callables (refine-method-list wrapped-methods-initial class-name))) (list `(define (,(build-identifier (string-append "wrap-convert-assert-" class-name)) obj p n s c) - (let ((raise-error + (let ((raise-error (lambda (method-name num-args) - (raise (make-exn:fail - (string->immutable-string - (format "~a broke the contract with ~a here, expected an object with a method ~a accepting ~a args" - n p method-name num-args)) c))))) + (raise (make-exn:fail + (format "~a broke the contract with ~a here, expected an object with a method ~a accepting ~a args" + n p method-name num-args) + c))))) (and ,@(map method->check/error (filter (lambda (m) (not (eq? 'ctor (method-record-rtype m)))) wrapped-methods)))) #;(c:contract ,(methods->contract (filter (lambda (m) (not (eq? 'ctor (method-record-rtype m)))) @@ -940,9 +940,8 @@ `(define/public (,(build-identifier define-name) . args) (unless (= (length args) ,(length list-of-args)) (raise (make-exn:fail:contract:arity - (string->immutable-string - (format "~a broke the contract with ~a here, method ~a of ~a called with ~a args, instead of ~a" - neg-blame pos-blame ,(method-record-name method) ,(class-name) (length args) ,(length list-of-args))) + (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)) cc-marks))) (let (,@(map (lambda (arg type ref) `(,arg ,(convert-value (assert-value `(list-ref args ,ref) type #t 'method-arg (method-record-name method)) type #t))) @@ -1011,21 +1010,21 @@ (lambda (ok?) `(let ((v-1 ,value)) (if (,ok? v-1) v-1 - (raise (make-exn:fail (string->immutable-string - ,(case kind - ((unspecified) - `(format "~a broke the contract with ~a here, type-mismatch expected ~a given ~a" - neg-blame pos-blame (quote ,type) v-1)) - ((field) - `(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)) - ((method-arg) - `(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)) - ((method-ret) - `(format "~a broke the contract with ~a here, type-mismatch for method return of ~a in ~a: expected ~a given ~a" - neg-blame pos-blame ,name ,(class-name) (quote ,type) v-1))) - ) cc-marks))))))) + (raise (make-exn:fail + ,(case kind + ((unspecified) + `(format "~a broke the contract with ~a here, type-mismatch expected ~a given ~a" + neg-blame pos-blame (quote ,type) v-1)) + ((field) + `(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)) + ((method-arg) + `(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)) + ((method-ret) + `(format "~a broke the contract with ~a here, type-mismatch for method return of ~a in ~a: expected ~a given ~a" + neg-blame pos-blame ,name ,(class-name) (quote ,type) v-1))) + cc-marks))))))) (case type ((int byte short long) (check 'integer?)) ((float double) (check 'real?)) @@ -1810,8 +1809,8 @@ (define translate-throw (lambda (expr key src) (create-syntax #f `(let* ((obj ,expr) - (exn (make-java:exception - (string->immutable-string (send (send obj |getMessage|) get-mzscheme-string)) + (exn (make-java:exception + (send (send obj |getMessage|) get-mzscheme-string) (current-continuation-marks) obj))) (send obj set-exception! exn) (,(create-syntax #f 'raise (build-src key)) exn)) @@ -2133,9 +2132,9 @@ `(let ((val ,val)) (if (string? val) (make-java-string val) - (raise (make-exn:fail (string->immutable-string - (format "~a broke infered contract here: expected String received ~a" - ,(class-name) val)) (current-continuation-marks)))))))) + (raise (make-exn:fail (format "~a broke infered contract here: expected String received ~a" + ,(class-name) val) + (current-continuation-marks)))))))) ((unknown-ref? type) `(let ((val ,val)) (if (string? val) @@ -3038,4 +3037,4 @@ (lambda (id src) (create-syntax #f (build-identifier id) (build-src src)))) - ) \ No newline at end of file + ) diff --git a/collects/setup/setup-unit.ss b/collects/setup/setup-unit.ss index e826d0a4ee..4d56a8e65e 100644 --- a/collects/setup/setup-unit.ss +++ b/collects/setup/setup-unit.ss @@ -158,17 +158,17 @@ [(owner pkg-name maj-str min-str) (let ([maj (string->number maj-str)] [min (string->number min-str)]) - (unless maj (error 'setup-plt "Bad major version for PLaneT package: ~s" maj-str)) - (unless min (error 'setup-plt "Bad minor version for PLaneT package: ~s" min-str)) + (unless maj (error 'setup-plt "Bad major version for PLaneT package: ~e" maj-str)) + (unless min (error 'setup-plt "Bad minor version for PLaneT package: ~e" min-str)) (let ([pkg (lookup-package-by-keys owner pkg-name maj min min)]) (if pkg pkg - (error 'setup-plt "Not an installed PLaneT package: (~s ~s ~s ~s)" owner pkg-name maj min))))] + (error 'setup-plt "Not an installed PLaneT package: (~e ~e ~e ~e)" owner pkg-name maj min))))] [_ spec])) (define (planet->cc path owner pkg-file extra-path maj min) (unless (path? path) - (error 'path->cc "non-path when building package ~a" pkg-file)) + (error 'planet->cc "non-path when building package ~e" pkg-file)) (let/ec return (let* ([info (with-handlers ([exn:fail? (warning-handler #f)]) (get-info/full path))] @@ -176,12 +176,10 @@ (lambda (x) (when x (unless (string? x) - (error - (string->immutable-string - (format - "'name' result from directory ~s is not a string:" - path)) - x)))))]) + (error 'planet->cc + "'name' result from directory ~e is not a string: ~e" + path + x)))))]) (make-cc #f path diff --git a/collects/skipper/debug-tool.ss b/collects/skipper/debug-tool.ss index 44896acc97..6669f3066e 100644 --- a/collects/skipper/debug-tool.ss +++ b/collects/skipper/debug-tool.ss @@ -597,8 +597,8 @@ (thread (lambda () (raise (make-exn:break - (string->immutable-string - (format "~a (suspending)" (exn-message exn))) + (format "~a (suspending)" + (exn-message exn)) marks cont)))) (send parent suspend oeh (continuation-mark-set->list marks debug-key) 'break) @@ -759,4 +759,4 @@ (drscheme:get/extend:extend-definitions-text debug-definitions-text-mixin) (drscheme:get/extend:extend-interactions-text debug-interactions-text-mixin) - (drscheme:get/extend:extend-unit-frame debug-unit-frame-mixin)))) \ No newline at end of file + (drscheme:get/extend:extend-unit-frame debug-unit-frame-mixin)))) diff --git a/collects/srfi/14/char-set.ss b/collects/srfi/14/char-set.ss index 62f72d0f4c..a5a373bac1 100644 --- a/collects/srfi/14/char-set.ss +++ b/collects/srfi/14/char-set.ss @@ -156,8 +156,7 @@ (upper . > . #x110000) (lower . >= . upper)) (raise (make-exn:fail:contract - (string->immutable-string - (format "ucs-range->char-set: invalid range: [~a, ~a)" lower upper)) + (format "ucs-range->char-set: invalid range: [~a, ~a)" lower upper) (current-continuation-marks)))) (char-set-union cs (cond diff --git a/collects/srfi/43/constructors.ss b/collects/srfi/43/constructors.ss index e0a5fdf305..1da8408a58 100644 --- a/collects/srfi/43/constructors.ss +++ b/collects/srfi/43/constructors.ss @@ -149,9 +149,8 @@ (unless (<= start end) (raise (make-exn:fail:contract - (string->immutable-string - (format "~a: indices (~a, ~a) out of range for vector: ~a" - 'vector-copy start end vec)) + (format "~a: indices (~a, ~a) out of range for vector: ~a" + 'vector-copy start end vec) (current-continuation-marks)))) (let ((new-vector (apply make-vector (cons (- end start) fill)))) diff --git a/collects/srfi/43/util.ss b/collects/srfi/43/util.ss index abfb1bbeef..60f2eaf1e0 100644 --- a/collects/srfi/43/util.ss +++ b/collects/srfi/43/util.ss @@ -54,9 +54,8 @@ (< index (vector-length vec))) (raise (make-exn:fail:contract - (string->immutable-string - (format "~a: index ~a out of range for vector: ~a" - callee index vec)) + (format "~a: index ~a out of range for vector: ~a" + callee index vec) (current-continuation-marks))))) @@ -71,9 +70,8 @@ (unless (<= 0 index (vector-length vec)) (raise (make-exn:fail:contract - (string->immutable-string - (format "~a: index ~a out of range for vector: ~a" - callee index vec)) + (format "~a: index ~a out of range for vector: ~a" + callee index vec) (current-continuation-marks))))) ;;; (CHECK-INDICES ) -> @@ -88,9 +86,8 @@ (unless (<= 0 start end (vector-length vec)) (raise (make-exn:fail:contract - (string->immutable-string - (format "~a: indices (~a, ~a) out of range for vector: ~a" - callee start end vec)) + (format "~a: indices (~a, ~a) out of range for vector: ~a" + callee start end vec) (current-continuation-marks))))) (define (nonneg-int? x) diff --git a/collects/swindle/tiny-clos.ss b/collects/swindle/tiny-clos.ss index 23cb31eb56..bb2462bb1d 100644 --- a/collects/swindle/tiny-clos.ss +++ b/collects/swindle/tiny-clos.ss @@ -130,10 +130,9 @@ (let loop ([fmt-args '()] [args args] [a fmt-num]) (if (zero? a) (raise (exn-maker - (string->immutable-string - (if sym - (apply format (concat "~s: " fmt) sym (reverse! fmt-args)) - (apply format fmt (reverse! fmt-args)))) + (if sym + (apply format (concat "~s: " fmt) sym (reverse! fmt-args)) + (apply format fmt (reverse! fmt-args))) (current-continuation-marks) . args)) (loop (cons (car args) fmt-args) (cdr args) (sub1 a)))))) diff --git a/collects/syntax/moddep.ss b/collects/syntax/moddep.ss index e8a1394d82..877e198cd5 100644 --- a/collects/syntax/moddep.ss +++ b/collects/syntax/moddep.ss @@ -30,10 +30,9 @@ (define (raise-wrong-module-name filename expected-name name) (raise (make-exn:fail - (string->immutable-string - (format - "load-handler: expected a `module' declaration for `~a' in ~s, found: ~a" - expected-name filename name)) + (format + "load-handler: expected a `module' declaration for `~a' in ~s, found: ~a" + expected-name filename name) (current-continuation-marks)))) (define (check-module-form exp expected-module filename) @@ -43,10 +42,9 @@ (and filename (raise (make-exn:fail - (string->immutable-string - (format - "load-handler: expected a `module' declaration for `~a' in ~s, but found end-of-file" - expected-module filename)) + (format + "load-handler: expected a `module' declaration for `~a' in ~s, but found end-of-file" + expected-module filename) (current-continuation-marks))))] [(compiled-module-expression? (syntax-e exp)) (if (eq? (module-compiled-name (syntax-e exp)) @@ -76,10 +74,9 @@ (and filename (raise (make-exn:fail - (string->immutable-string - (format - "load-handler: expected a `module' declaration for `~a' in ~s, but found something else" - expected-module filename)) + (format + "load-handler: expected a `module' declaration for `~a' in ~s, but found something else" + expected-module filename) (current-continuation-marks))))])) (define re:suffix #rx#"\\..*$") @@ -171,9 +168,8 @@ (date>=? so path-d)) (if extension-handler (extension-handler so #f) - (raise (make-exn:get-module-code - (string->immutable-string - (format "get-module-code: cannot use extension file; ~e" so)) + (raise (make-exn:get-module-code + (format "get-module-code: cannot use extension file; ~e" so) (current-continuation-marks) so)))] ;; Or maybe even a _loader.so? @@ -188,16 +184,15 @@ => (lambda (loader) (if extension-handler (extension-handler loader #t) - (raise (make-exn:get-module-code - (string->immutable-string - (format "get-module-code: cannot use _loader file: ~e" - _loader-so)) + (raise (make-exn:get-module-code + (format "get-module-code: cannot use _loader file: ~e" + _loader-so) (current-continuation-marks) loader))))] ;; Report a not-there error [else - (raise (make-exn:get-module-code - (string->immutable-string (format "get-module-code: no such file: ~e" path)) + (raise (make-exn:get-module-code + (format "get-module-code: no such file: ~e" path) (current-continuation-marks) #f))]))))) diff --git a/collects/syntax/readerr.ss b/collects/syntax/readerr.ss index 6f47f53fcc..74482c13a2 100644 --- a/collects/syntax/readerr.ss +++ b/collects/syntax/readerr.ss @@ -37,17 +37,15 @@ (raise (make-exn:fail:read - (string->immutable-string - (format "~a~a" - (cond - [(not (error-print-source-location)) ""] - [(and line col) - (format "~a:~a:~a: " source-name line col)] - [pos - (format "~a::~a: " source-name pos)] - [else - (format "~a: " source-name)]) - msg)) + (format "~a~a" + (cond [(not (error-print-source-location)) ""] + [(and line col) + (format "~a:~a:~a: " source-name line col)] + [pos + (format "~a::~a: " source-name pos)] + [else + (format "~a: " source-name)]) + msg) (current-continuation-marks) (list-immutable (make-srcloc source-name line col pos span))))))) diff --git a/collects/tests/mztake/test-harness.ss b/collects/tests/mztake/test-harness.ss index 342fca28ce..bafc2a43a5 100644 --- a/collects/tests/mztake/test-harness.ss +++ b/collects/tests/mztake/test-harness.ss @@ -20,11 +20,10 @@ [print-struct #t]) (when (or (eq? (print-tests) (first result)) (eq? (print-tests) #t)) - (pretty-print result)) (when (and (eq? (print-tests) 'stop) (eq? (first result) 'bad)) - (raise (make-exn:test (string->immutable-string (format "test failed: ~a" result)) + (raise (make-exn:test (format "test failed: ~a" result) (current-continuation-marks)))))) diff --git a/collects/web-server/dispatchers/dispatch-passwords.ss b/collects/web-server/dispatchers/dispatch-passwords.ss index 6ade2130a4..1ed1a1c043 100644 --- a/collects/web-server/dispatchers/dispatch-passwords.ss +++ b/collects/web-server/dispatchers/dispatch-passwords.ss @@ -80,9 +80,9 @@ ;; exn:password-file is raised. (define (read-passwords password-path) (with-handlers ([void (lambda (exn) - (raise (make-exn:password-file (string->immutable-string - (format "could not load password file ~a" password-path)) - (current-continuation-marks))))]) + (raise (make-exn:password-file + (format "could not load password file ~a" password-path) + (current-continuation-marks))))]) (let ([passwords (let ([raw (load password-path)]) (unless (password-list? raw) @@ -130,4 +130,4 @@ (authentication-responder uri `(WWW-Authenticate . ,(format " Basic realm=\"~a\"" realm))) - method))) \ No newline at end of file + method))) diff --git a/collects/web-server/dispatchers/dispatch-servlets.ss b/collects/web-server/dispatchers/dispatch-servlets.ss index efa55d13f4..9f49edb6ca 100644 --- a/collects/web-server/dispatchers/dispatch-servlets.ss +++ b/collects/web-server/dispatchers/dispatch-servlets.ss @@ -268,7 +268,7 @@ entry)] [else (raise (make-exn:fail:filesystem:exists:servlet - (string->immutable-string (format "Couldn't find ~a" servlet-filename)) + (format "Couldn't find ~a" servlet-filename) (current-continuation-marks) ))])) ;; load-servlet/path path -> (or/c #f cache-entry) diff --git a/collects/web-server/managers/lru.ss b/collects/web-server/managers/lru.ss index 1165b676ea..89f75b361e 100644 --- a/collects/web-server/managers/lru.ss +++ b/collects/web-server/managers/lru.ss @@ -45,8 +45,7 @@ (hash-table-get instances instance-id (lambda () (raise (make-exn:fail:servlet-manager:no-instance - (string->immutable-string - (format "No instance for id: ~a" instance-id)) + (format "No instance for id: ~a" instance-id) (current-continuation-marks) instance-expiration-handler))))) instance) @@ -95,8 +94,7 @@ (hash-table-get htable a-k-id (lambda () (raise (make-exn:fail:servlet-manager:no-continuation - (string->immutable-string - (format "No continuation for id: ~a" a-k-id)) + (format "No continuation for id: ~a" a-k-id) (current-continuation-marks) instance-expiration-handler)))) [(list salt k expiration-handler count) @@ -105,8 +103,7 @@ (if (or (not (eq? salt a-salt)) (not k)) (raise (make-exn:fail:servlet-manager:no-continuation - (string->immutable-string - (format "No continuation for id: ~a" a-k-id)) + (format "No continuation for id: ~a" a-k-id) (current-continuation-marks) (if expiration-handler expiration-handler @@ -176,4 +173,4 @@ (collect) (loop msecs0 (seconds->msecs time1))))))))) - the-manager)) \ No newline at end of file + the-manager)) diff --git a/collects/web-server/managers/none.ss b/collects/web-server/managers/none.ss index e6fe134b02..cc73f222b6 100644 --- a/collects/web-server/managers/none.ss +++ b/collects/web-server/managers/none.ss @@ -18,8 +18,7 @@ (define (instance-lookup instance-id) (raise (make-exn:fail:servlet-manager:no-instance - (string->immutable-string - (format "No instance for id: ~a" instance-id)) + (format "No instance for id: ~a" instance-id) (current-continuation-marks) instance-expiration-handler))) @@ -48,4 +47,4 @@ continuation-store! continuation-lookup ; Specific - instance-expiration-handler))) \ No newline at end of file + instance-expiration-handler))) diff --git a/collects/web-server/managers/timeouts.ss b/collects/web-server/managers/timeouts.ss index 270f880484..ccfd47c32a 100644 --- a/collects/web-server/managers/timeouts.ss +++ b/collects/web-server/managers/timeouts.ss @@ -50,8 +50,7 @@ (hash-table-get instances instance-id (lambda () (raise (make-exn:fail:servlet-manager:no-instance - (string->immutable-string - (format "No instance for id: ~a" instance-id)) + (format "No instance for id: ~a" instance-id) (current-continuation-marks) instance-expiration-handler))))) (increment-timer! (instance-timer instance) @@ -60,10 +59,10 @@ (define (instance-lock! instance-id) (define instance (instance-lookup instance-id)) - (set-instance-locked?! instance #t)) + (set-instance-locked?! instance #t)) (define (instance-unlock! instance-id) (define instance (instance-lookup instance-id)) - (set-instance-locked?! instance #f)) + (set-instance-locked?! instance #f)) ;; Continuation table (define-struct k-table (next-id-fn htable)) @@ -105,8 +104,7 @@ (hash-table-get htable a-k-id (lambda () (raise (make-exn:fail:servlet-manager:no-continuation - (string->immutable-string - (format "No continuation for id: ~a" a-k-id)) + (format "No continuation for id: ~a" a-k-id) (current-continuation-marks) instance-expiration-handler)))) [(list salt k expiration-handler k-timer) @@ -115,8 +113,7 @@ (if (or (not (eq? salt a-salt)) (not k)) (raise (make-exn:fail:servlet-manager:no-continuation - (string->immutable-string - (format "No continuation for id: ~a" a-k-id)) + (format "No continuation for id: ~a" a-k-id) (current-continuation-marks) (if expiration-handler expiration-handler @@ -137,4 +134,4 @@ continuation-timer-length ; Private instances - next-instance-id))) \ No newline at end of file + next-instance-id))) diff --git a/collects/web-server/private/util.ss b/collects/web-server/private/util.ss index af0f0caa8b..268a42aee7 100644 --- a/collects/web-server/private/util.ss +++ b/collects/web-server/private/util.ss @@ -41,10 +41,8 @@ ;; network-error: symbol string . values -> void ;; throws a formatted exn:fail:network (define (network-error src fmt . args) - (raise (make-exn:fail:network - (string->immutable-string - (format "~a: ~a" src (apply format fmt args))) - (current-continuation-marks)))) + (raise (make-exn:fail:network (format "~a: ~a" src (apply format fmt args)) + (current-continuation-marks)))) ;; build-path-unless-absolute : path-string? path-string? -> path? (define (build-path-unless-absolute base path) diff --git a/collects/xml/private/reader.ss b/collects/xml/private/reader.ss index 2f291eb410..44622b64d6 100644 --- a/collects/xml/private/reader.ss +++ b/collects/xml/private/reader.ss @@ -443,27 +443,21 @@ [offset (location-offset the-pos)]) (raise (make-exn:xml - (string->immutable-string - (format "read-xml: lex-error: at position ~a: ~a" - (format-source the-pos) - (apply format str rest))) + (format "read-xml: lex-error: at position ~a: ~a" + (format-source the-pos) + (apply format str rest)) (current-continuation-marks) - (list-immutable (make-srcloc - (object-name in) - #f - #f - offset - 1)))))) - + (list-immutable + (make-srcloc (object-name in) #f #f offset 1)))))) + ;; parse-error : (listof srcloc) (listof TST) *-> alpha ;; raises a parsing error, using exn:xml (define (parse-error src fmt . args) - (raise (make-exn:xml - (string->immutable-string - (apply format (string-append "read-xml: parse-error: " fmt) args)) - (current-continuation-marks) - src))) - + (raise (make-exn:xml (string-append "read-xml: parse-error: " + (apply format fmt args)) + (current-continuation-marks) + src))) + ;; format-source : Location -> string ;; to format the source location for an error message (define (format-source loc) diff --git a/collects/xml/private/xexpr.ss b/collects/xml/private/xexpr.ss index c3676921c5..5b08521ae0 100644 --- a/collects/xml/private/xexpr.ss +++ b/collects/xml/private/xexpr.ss @@ -73,22 +73,19 @@ (correct-xexpr? part true false)) (cdr x))) (false (make-exn:invalid-xexpr - (string->immutable-string - (format - "Expected a symbol as the element name, given ~a" - (car x))) - (current-continuation-marks) - x))))) + (format + "Expected a symbol as the element name, given ~a" + (car x)) + (current-continuation-marks) + x))))) (else (false (make-exn:invalid-xexpr - (string->immutable-string - (format - (string-append - "Expected a string, symbol, number, comment, " - "processing instruction, or list, given ~a") - x)) - (current-continuation-marks) - x))))) + (format (string-append + "Expected a string, symbol, number, comment, " + "processing instruction, or list, given ~a") + x) + (current-continuation-marks) + x))))) ;; has-attribute? : List -> Boolean ;; True if the Xexpr provided has an attribute list. @@ -111,10 +108,9 @@ (true)) (false (make-exn:invalid-xexpr - (string->immutable-string - (format "Expected a pair, given ~a" attr)) - (current-continuation-marks) - attr)))))) + (format "Expected a pair, given ~a" attr) + (current-continuation-marks) + attr)))))) ;; attribute-symbol-string? : List (-> a) (exn -> a) -> a ;; True if the list is a list of String,Symbol pairs. @@ -123,15 +119,13 @@ (if (string? (cadr attr)) (true) (false (make-exn:invalid-xexpr - (string->immutable-string - (format "Expected a string, given ~a" (cadr attr))) - (current-continuation-marks) - (cadr attr)))) + (format "Expected a string, given ~a" (cadr attr)) + (current-continuation-marks) + (cadr attr)))) (false (make-exn:invalid-xexpr - (string->immutable-string - (format "Expected a symbol, given ~a" (car attr))) - (current-continuation-marks) - (cadr attr))))) + (format "Expected a symbol, given ~a" (car attr)) + (current-continuation-marks) + (cadr attr))))) ;; ; end xexpr? helpers ;; ;; ;; ;; ;; ;; ;; ;;