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