add #:extra-srclocs argument to raise-read-error

Also, modernize the error checking to use raise-argument-error
and generally Rackety
This commit is contained in:
Robby Findler 2013-01-11 20:00:09 -06:00
parent 2ac6615da9
commit 2067534431
2 changed files with 49 additions and 49 deletions

View File

@ -1,52 +1,50 @@
; Don't change this module to #lang, since it's used by syntax/module-reader
(module readerr racket/private/base
(provide raise-read-error
raise-read-eof-error)
(define (raise-read-error msg source-name line col pos span)
(-raise-read-error make-exn:fail:read msg source-name line col pos span))
raise-read-eof-error)
(define (raise-read-error msg source-name line col pos span #:extra-srclocs [extra-srclocs '()])
(-raise-read-error make-exn:fail:read msg source-name line col pos span
extra-srclocs
'raise-read-error))
(define (raise-read-eof-error msg source-name line col pos span)
(-raise-read-error make-exn:fail:read:eof msg source-name line col pos span))
(define (-raise-read-error make-exn:fail:read msg source-name line col pos span)
(let ([bad-type
(lambda (which what)
(raise-type-error 'raise-read-error
what
which
msg source-name line col pos span))]
[ordinal? (lambda (x)
(or (not x)
(and (number? x) (exact? x) (positive? x) (integer? x))))]
[ordinal "positive exact integer"]
[cardinal? (lambda (x)
(or (not x)
(and (number? x) (exact? x) (not (negative? x)) (integer? x))))]
[cardinal "non-negative exact integer"])
(-raise-read-error make-exn:fail:read:eof msg source-name line col pos span '()
'raise-read-eof-error))
(define (-raise-read-error make-exn:fail:read msg source-name line col pos span extra-srclocs name)
(define (bad-type which what)
(raise-argument-error name what which
msg source-name line col pos span))
(unless (string? msg)
(bad-type 0 "string"))
(unless (ordinal? line)
(bad-type 2 ordinal))
(unless (cardinal? col)
(bad-type 3 cardinal))
(unless (ordinal? pos)
(bad-type 4 ordinal))
(unless (cardinal? span)
(bad-type 5 cardinal))
(raise
(make-exn:fail:read
(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 (make-srcloc
source-name line col pos span)))))))
(unless (string? msg) (bad-type 0 "string"))
(unless (ordinal? line) (bad-type 2 ordinal))
(unless (cardinal? col) (bad-type 3 cardinal))
(unless (ordinal? pos) (bad-type 4 ordinal))
(unless (cardinal? span) (bad-type 5 cardinal))
(unless (and (list? extra-srclocs) (andmap srcloc? extra-srclocs))
(raise-argument-error name "(list/c srcloc?)" extra-srclocs))
(raise
(make-exn:fail:read
(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)
(cons (make-srcloc source-name line col pos span)
extra-srclocs))))
(define (ordinal? x)
(or (not x)
(exact-positive-integer? x)))
(define ordinal "(or/c exact-positive-integer? #f)")
(define (cardinal? x)
(or (not x)
(exact-nonnegative-integer? x)))
(define cardinal "(or/c exact-nonnegative-integer? #f)"))

View File

@ -10,14 +10,16 @@
[line (or/c number? false/c)]
[col (or/c number? false/c)]
[pos (or/c number? false/c)]
[span (or/c number? false/c)])
[span (or/c number? false/c)]
[#:extra-srclocs extra-srclocs (listof srcloc?) '()])
any]{
Creates and raises an @racket[exn:fail:read] exception, using
@racket[msg-string] as the base error message.
Source-location information is added to the error message using the
last five arguments (if the @racket[error-print-source-location]
last five arguments and the @racket[extra-srclocs]
(if the @racket[error-print-source-location]
parameter is set to @racket[#t]). The @racket[source] argument is an
arbitrary value naming the source location---usually a file path
string. Each of the @racket[line], @racket[pos] arguments is