1#lang racket/base 2(require "config.rkt") 3 4(provide reader-error 5 bad-syntax-error 6 catch-and-reraise-as-reader) 7 8(define (reader-error in config 9 #:continuation-marks [continuation-marks (current-continuation-marks)] 10 #:due-to [due-to #\x] 11 #:who [who (if (read-config-for-syntax? config) 12 'read-syntax 13 'read)] 14 #:end-pos [end-pos #f] 15 str . args) 16 (define msg (format "~a: ~a" who (apply format str args))) 17 (define srcloc (and in (port+config->srcloc in config 18 #:end-pos end-pos))) 19 (raise 20 ((cond 21 [(eof-object? due-to) exn:fail:read:eof] 22 [(not (char? due-to)) exn:fail:read:non-char] 23 [else exn:fail:read]) 24 (let ([s (and (error-print-source-location) 25 srcloc 26 (srcloc->string srcloc))]) 27 (if s 28 (string-append s ": " msg) 29 msg)) 30 continuation-marks 31 (if srcloc 32 (list srcloc) 33 null)))) 34 35(define (bad-syntax-error in config str #:due-to [due-to #\x]) 36 (reader-error in config #:due-to due-to "bad syntax `~a`" str)) 37 38 39(define-syntax-rule (catch-and-reraise-as-reader in config expr) 40 (catch-and-reraise-as-reader/proc in config (lambda () expr))) 41 42(define (catch-and-reraise-as-reader/proc in config thunk) 43 (with-handlers ([exn:fail? (lambda (exn) 44 (reader-error in config 45 "~a" 46 (let ([s (exn-message exn)]) 47 (regexp-replace "^[a-z-]*: " s "")) 48 #:continuation-marks (exn-continuation-marks exn)))]) 49 (thunk))) 50