/usr/share/racket/collects/syntax/macro-testing.rkt is in racket-common 6.7-3.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 | #lang racket/base
(require (for-syntax racket/base
racket/syntax
syntax/strip-context
syntax/keyword))
(provide phase1-eval
convert-syntax-error
convert-compile-time-error)
(begin-for-syntax
(define (exn->raise-syntax e)
(cond [(exn:fail:syntax? e)
#`(raise (make-exn:fail:syntax
#,(exn-message e)
(current-continuation-marks)
;; Lexical context must be stripped to avoid "unsealed local-definition context
;; found in fully expanded form" error in cases like the following:
;; (convert-syntax-error (let () (define x) x))
#,(with-syntax ([(expr ...) (map strip-context (exn:fail:syntax-exprs e))])
#'(list (quote-syntax expr) ...))))]
[(exn? e)
(with-syntax ([make-exn
(cond [(exn:fail? e) #'make-exn:fail]
[else #'make-exn])])
#`(raise (make-exn #,(exn-message e)
(current-continuation-marks))))]
[else
#`(raise (make-exn #,(format "non-exception value raised: ~e" e)
(current-continuation-marks)))])))
(define-syntax (phase1-eval stx)
(if (eq? (syntax-local-context) 'expression)
(syntax-case stx ()
[(phase1-eval ct-expr . options)
(let ()
(define opts (parse-keyword-options/eol
#'options
`((#:quote ,check-identifier)
(#:catch? ,check-stx-boolean))
#:no-duplicates? #t
#:context stx))
(define quote-form (options-select-value opts '#:quote #:default #'quote))
(define catch? (options-select-value opts '#:catch? #:default #t))
(with-handlers ([(lambda (e) catch?) exn->raise-syntax])
(with-syntax ([quote quote-form]
[result (syntax-local-eval #'ct-expr)])
#'(quote result)))
#|
;; Alternative version
(with-syntax ([quote-form quote-form]
[catch? catch?])
#'(let-syntax ([aux-macro
(lambda _
(with-handlers ([(lambda (e) catch?) exn->raise-syntax])
(with-syntax ([result ct-expr])
;; want syntax-local-introduce ?
#'(quote-form result))))])
(aux-macro)))
|#)])
#`(#%expression #,stx)))
(begin-for-syntax
(define (do-convert-ct-error stx exn-pred?)
(if (eq? (syntax-local-context) 'expression)
(syntax-case stx ()
[(_ expr)
(with-handlers ([exn-pred? exn->raise-syntax]
[void
(lambda (e)
(eprintf "didn't catch ~e\n" e)
(raise e))])
(local-expand #'expr 'expression null))])
#`(#%expression #,stx))))
(define-syntax (convert-syntax-error stx)
(parameterize ((error-print-source-location #f))
(do-convert-ct-error stx exn:fail:syntax?)))
(define-syntax (convert-compile-time-error stx)
(do-convert-ct-error stx (lambda (e) #t)))
|