added unstable/macro-testing

collects/unstable/macro-testing.rkt

@@ -0,0 +1,80 @@
+#lang racket/base
+(require (for-syntax racket/base
+                     racket/syntax
+                     syntax/keyword))
+(provide phase1-eval
+         convert-syntax-error
+         convert-compile-time-error)
+
+(begin-for-syntax
+ (define (exn->raise-syntax e)
+   (cond #|
+         ;; Preserving exn:fail:syntax causes the "unsealed local-definition context found
+         ;; in fully expanded form" error in some tests.
+         [(exn:fail:syntax? e)
+          #`(raise (make-exn:fail:syntax
+                    #,(exn-message e)
+                    (current-continuation-marks)
+                    #,(with-syntax ([(expr ...) (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)))

collects/unstable/scribblings/macro-testing.scrbl

@@ -0,0 +1,74 @@
+#lang scribble/manual
+@(require scribble/eval "utils.rkt"
+          (for-label racket/base 
+                     racket/contract
+                     racket/struct-info
+                     rackunit
+                     unstable/macro-testing))
+
+@(define the-eval (make-base-eval))
+@(the-eval '(require rackunit unstable/macro-testing (for-syntax racket/base racket/struct-info)))
+
+@title[#:tag "macro-testing"]{Macro Testing}
+@unstable-header[]
+
+@defmodule[unstable/macro-testing]
+
+@defform/subs[(phase1-eval ct-expr maybe-quote maybe-catch?)
+              ([maybe-quote (code:line)
+                            (code:line #:quote quote-id)]
+               [maybe-catch? (code:line)
+                             (code:line #:catch? catch?)])]{
+
+Evaluates @racket[ct-expr] at compile time and quotes the result using
+@racket[quote-id], which defaults to @racket[quote]. Another suitable
+argument for @racket[quote-id] is @racket[quote-syntax].
+
+If @racket[catch?] is @racket[#t], then if the evaluation of
+@racket[ct-expr] raises a compile-time exception, it is caught and
+converted to a run-time exception.
+
+@examples[#:eval the-eval
+(struct point (x y))
+(phase1-eval (extract-struct-info (syntax-local-value #'point)))
+(phase1-eval (extract-struct-info (syntax-local-value #'point))
+             #:quote quote-syntax)
+]
+}
+
+@defform[(convert-compile-time-error expr)]{
+
+Equivalent to @racket[(#%expression expr)] except if expansion of
+@racket[expr] causes a compile-time exception to be raised; in that
+case, the compile-time exception is converted to a run-time exception
+raised when the expression is evaluated.
+
+Use @racket[convert-compile-time-error] to write tests for
+compile-time error checking like syntax errors:
+
+@examples[#:eval the-eval
+(check-exn #rx"missing an \"else\" expression"
+           (lambda () (convert-compile-time-error (if 1 2))))
+(check-exn #rx"missing formals and body"
+           (lambda () (convert-compile-time-error (lambda))))
+]
+
+Without the use of @racket[convert-compile-time-error], the checks
+above would not be executed because the test program would not compile.
+}
+
+@defform[(convert-syntax-error expr)]{
+
+Like @racket[convert-compile-time-error], but only catches compile-time
+@racket[exn:fail:syntax?] exceptions and sets
+@racket[error-print-source-location] to @racket[#f] around the
+expansion of @racket[expr] to make the message easier to match
+exactly.
+
+@examples[#:eval the-eval
+(check-exn #rx"^lambda: bad syntax$"
+           (lambda () (convert-syntax-error (lambda))))
+]
+}
+
+@(close-eval the-eval)

collects/unstable/scribblings/unstable.scrbl

@@ -91,6 +91,7 @@ Keep documentation and tests up to date.
 @include-section["lazy-require.scrbl"]
 @include-section["list.scrbl"]
 @include-section["logging.scrbl"]
+@include-section["macro-testing.scrbl"]
 @include-section["markparam.scrbl"]
 @include-section["match.scrbl"]
 @include-section["open-place.scrbl"]