81 lines
3.4 KiB
Racket
81 lines
3.4 KiB
Racket
#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)))
|