suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Move unstable/macro-testing to syntax/macro-testing.

Browse Source
This commit is contained in:
Vincent St-Amour 2015-07-31 12:02:49 -05:00
parent c541f6b4ba
commit 21c44635f6
4 changed files with 83 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
pkgs/racket-test/info.rkt
View File

@ -1,8 +1,7 @@
#lang info
(define collection 'multi)
(define deps '("unstable-macro-testing-lib"
"compiler-lib"
(define deps '("compiler-lib"
"sandbox-lib"
"compatibility-lib"
"eli-tester"

2
pkgs/racket-test/tests/generic/errors.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base
(require racket/generic racket/engine unstable/macro-testing)
(require racket/generic racket/engine syntax/macro-testing)
(module+ test
(require rackunit)

2
pkgs/racket-test/tests/stxparse/setup.rkt
View File

@ -4,7 +4,7 @@
(only-in syntax/parse/private/residual
attribute-binding)
syntax/parse/private/residual-ct ;; for attr functions
unstable/macro-testing
syntax/macro-testing
(for-syntax racket/base))
(provide tok

80
racket/collects/syntax/macro-testing.rkt Normal file
View File

@ -0,0 +1,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)))