diff --git a/pkgs/racket-test/info.rkt b/pkgs/racket-test/info.rkt index 5191419b6e..8cb93d6e80 100644 --- a/pkgs/racket-test/info.rkt +++ b/pkgs/racket-test/info.rkt @@ -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" diff --git a/pkgs/racket-test/tests/generic/errors.rkt b/pkgs/racket-test/tests/generic/errors.rkt index 18607db5f0..f3926c4c13 100644 --- a/pkgs/racket-test/tests/generic/errors.rkt +++ b/pkgs/racket-test/tests/generic/errors.rkt @@ -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) diff --git a/pkgs/racket-test/tests/stxparse/setup.rkt b/pkgs/racket-test/tests/stxparse/setup.rkt index 9fa3258d9b..857c4a194f 100644 --- a/pkgs/racket-test/tests/stxparse/setup.rkt +++ b/pkgs/racket-test/tests/stxparse/setup.rkt @@ -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 diff --git a/racket/collects/syntax/macro-testing.rkt b/racket/collects/syntax/macro-testing.rkt new file mode 100644 index 0000000000..a953d25947 --- /dev/null +++ b/racket/collects/syntax/macro-testing.rkt @@ -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)))