From 32e38ca0e4e145bf6f52ea820620fb42ad125df2 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Fri, 13 Nov 2009 21:41:01 +0000 Subject: [PATCH] macro-stepper: do compile-time evals when expanding fixes: (begin macro-def macro-use) pattern updated tests for lifts change svn: r16762 --- collects/macro-debugger/model/deriv-c.ss | 6 ++ collects/macro-debugger/model/deriv-parser.ss | 38 ++++++++- collects/macro-debugger/model/deriv-tokens.ss | 11 +++ collects/macro-debugger/model/reductions.ss | 9 +++ collects/macro-debugger/model/trace.ss | 77 +++++++++++++++++-- collects/macro-debugger/tool.ss | 2 +- collects/macro-debugger/view/stepper.ss | 19 ++--- collects/tests/macro-debugger/test-setup.ss | 8 +- .../tests/macro-debugger/tests/regression.ss | 15 ++++ .../macro-debugger/tests/syntax-macros.ss | 18 ++--- 10 files changed, 172 insertions(+), 31 deletions(-) diff --git a/collects/macro-debugger/model/deriv-c.ss b/collects/macro-debugger/model/deriv-c.ss index 03cff481ed..1e54bebddd 100644 --- a/collects/macro-debugger/model/deriv-c.ss +++ b/collects/macro-debugger/model/deriv-c.ss @@ -170,3 +170,9 @@ ;; (make-p:require-for-template ) ;; (make-p:provide ) ;; #f + + +;; ECTE represents expand/compile-time-evals +;; (make-ecte stx ?stx Deriv Deriv) + +(define-struct (ecte deriv) (first second) #:transparent) diff --git a/collects/macro-debugger/model/deriv-parser.ss b/collects/macro-debugger/model/deriv-parser.ss index a511e82eda..17c14f5875 100644 --- a/collects/macro-debugger/model/deriv-parser.ss +++ b/collects/macro-debugger/model/deriv-parser.ss @@ -1,6 +1,7 @@ #lang scheme/base (require (for-syntax scheme/base) + syntax/stx "yacc-ext.ss" "yacc-interrupted.ss" "deriv.ss" @@ -38,7 +39,7 @@ (src-pos) (tokens basic-tokens prim-tokens renames-tokens) (end EOF) - #;(debug "/tmp/ryan/DEBUG-PARSER.txt") + #|(debug "/tmp/ryan/DEBUG-PARSER.txt")|# (error deriv-error)) ;; tokens @@ -60,16 +61,47 @@ rename-one rename-list tag - IMPOSSIBLE) + IMPOSSIBLE + start + top-non-begin) ;; Entry point (productions (Expansion [(start EE/Lifts) $2] - [(start EE/Lifts/Interrupted) $2])) + [(start EE/Lifts/Interrupted) $2] + [(start ExpandCTE) $2] + [(start ExpandCTE/Interrupted) $2])) (productions/I + (ExpandCTE + [(visit start (? CheckImmediateMacro/Lifts) top-non-begin start (? EE) return) + (make ecte $1 $7 $3 $6)] + [(visit start CheckImmediateMacro/Lifts top-begin (? NextExpandCTEs) return) + (begin + (unless (list? $5) + (error "NextExpandCTEs returned non-list ~s" $5)) + (make ecte $1 $6 $3 + (make p:begin $4 $6 (list (stx-car $4)) #f + (make lderiv (cdr (stx->list $4)) + (and $6 (cdr (stx->list $6))) + #f + $5))))]) + + (CheckImmediateMacro/Lifts + [((? CheckImmediateMacro)) + $1] + [(CheckImmediateMacro lift-loop) + (let ([e1 (wderiv-e1 $1)] + [e2 $2]) + (make lift-deriv e1 e2 $1 $2 (make p:stop $2 $2 null #f)))]) + + (NextExpandCTEs + (#:skipped null) + [() null] + [(next (? ExpandCTE) (? NextExpandCTEs)) (cons $2 $3)]) + ;; Expand with possible lifting (EE/Lifts [((? EE)) $1] diff --git a/collects/macro-debugger/model/deriv-tokens.ss b/collects/macro-debugger/model/deriv-tokens.ss index a584faffe1..f425622e69 100644 --- a/collects/macro-debugger/model/deriv-tokens.ss +++ b/collects/macro-debugger/model/deriv-tokens.ss @@ -56,6 +56,9 @@ rename-list ; (list-of syntax) IMPOSSIBLE ; useful for error-handling clauses that have no NoError counterpart + + top-begin ; identifier + top-non-begin ; . )) (define-tokens renames-tokens @@ -160,6 +163,14 @@ (149 . prim-varref) (150 . ,token-lift-require) (151 . ,token-lift-provide) + + ;; Emitted from Scheme + (start . ,token-start) + (visit . ,token-visit) + (return . ,token-return) + (next . ,token-next) + (top-begin . ,token-top-begin) + (top-non-begin . ,token-top-non-begin) )) (define (tokenize sig-n val pos) diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss index b2a5748990..c5fe47ba06 100644 --- a/collects/macro-debugger/model/reductions.ss +++ b/collects/macro-debugger/model/reductions.ss @@ -271,6 +271,15 @@ (error 'reductions "unknown tagged syntax: ~s" tagged-stx)))] [Expr ?form next])] + ;; expand/compile-time-evals + + [(Wrap ecte (e1 e2 first second)) + (R [#:pattern ?form] + [#:pass1] + [Expr ?form first] + [#:pass2] + [Expr ?form second])] + ;; Lifts [(Wrap lift-deriv (e1 e2 first lifted-stx second)) diff --git a/collects/macro-debugger/model/trace.ss b/collects/macro-debugger/model/trace.ss index cc1be5493c..f341d28f6f 100644 --- a/collects/macro-debugger/model/trace.ss +++ b/collects/macro-debugger/model/trace.ss @@ -12,6 +12,7 @@ trace-verbose? events->token-generator current-expand-observe + expand/compile-time-evals trace-macro-limit trace-limit-handler) @@ -22,18 +23,18 @@ (define trace-verbose? (make-parameter #f)) ;; trace : stx -> Deriv -(define (trace stx) - (let-values ([(result events derivp) (trace* stx expand)]) +(define (trace stx [expander expand/compile-time-evals]) + (let-values ([(result events derivp) (trace* stx expander)]) (force derivp))) ;; trace/result : stx -> stx/exn Deriv -(define (trace/result stx) - (let-values ([(result events derivp) (trace* stx expand)]) +(define (trace/result stx [expander expand/compile-time-evals]) + (let-values ([(result events derivp) (trace* stx expander)]) (values result (force derivp)))) ;; trace* : stx (stx -> stx) -> stx/exn (list-of event) (promise-of Deriv) -(define (trace* stx expander) +(define (trace* stx [expander expand/compile-time-evals]) (let-values ([(result events) (expand/events stx expander)]) (values result events @@ -70,7 +71,7 @@ (if (and limit handler (exact-positive-integer? limit)) (lambda (x y) (add! x y) - (when (= x 8) ;; enter-macro + (when (eqv? x 8) ;; enter-macro (set! counter (add1 counter)) (when (= counter limit) (set! limit (handler counter))))) @@ -85,3 +86,67 @@ (add! 'EOF #f) (values result (reverse events))))) + + +(require syntax/stx + syntax/kerncase) + +(define (emit sig [val #f]) + ((current-expand-observe) sig val)) + +(define (expand/compile-time-evals stx) + (define (expand/cte stx) + (define _ (emit 'visit stx)) + (define e1 (expand-syntax-to-top-form stx)) + (define e2 + (syntax-case e1 (begin) + [(begin expr ...) + (begin + (emit 'top-begin e1) + (with-syntax ([(expr ...) + ;;left-to-right part of this map is important: + (map (lambda (e) + (emit 'next) + (expand/cte e)) + (syntax->list #'(expr ...)))] + [beg (stx-car e1)]) + (datum->syntax e1 (syntax-e (syntax (beg expr ...))) e1 e1)))] + [else + (begin + (emit 'top-non-begin) + (let ([e (expand-syntax e1)]) + (parameterize ((current-expand-observe void)) + (eval-compile-time-part e)) + e))])) + (emit 'return e2) + e2) + (emit 'start) + (expand/cte (namespace-syntax-introduce (datum->syntax #f stx)))) + +;; eval-compile-time-part : syntax boolean -> void +;; compiles the syntax it receives as an argument and evaluates the compile-time part of it. +;; pre: there are no top-level begins in stx. +(define (eval-compile-time-part stx) + (define (eval/compile stx) + (eval (compile-syntax stx))) + (kernel-syntax-case stx #f + [(#%require req ...) + (for ([req (syntax->list #'(req ...))]) + (namespace-require/expansion-time (syntax->datum req)))] + [(module . _) + (eval/compile stx)] + [(define-syntaxes . _) + (eval/compile stx)] + [(define-values-for-syntax . _) + (eval/compile stx)] + [(define-values (id ...) . _) + (with-syntax ([defvals (stx-car stx)] + [undefined (letrec ([x x]) x)]) + (for ([id (syntax->list #'(id ...))]) + (with-syntax ([id id]) + (eval/compile #'(defvals (id) undefined))))) + ;; Following doesn't work (namespace mismatch) + ;; (eval/compile #'(define-values (id ...) (let ([id #f] ...) (values id ...)))) + ] + [_else + (void)])) diff --git a/collects/macro-debugger/tool.ss b/collects/macro-debugger/tool.ss index 02464fb3ed..0524d45045 100644 --- a/collects/macro-debugger/tool.ss +++ b/collects/macro-debugger/tool.ss @@ -244,7 +244,7 @@ (parameterize ((trace-macro-limit (pref:macro-step-limit)) (trace-limit-handler (lambda (c) (handle-macro-limit c)))) - (trace* expr expand))) + (trace* expr))) (define/private (handle-macro-limit c) (define option diff --git a/collects/macro-debugger/view/stepper.ss b/collects/macro-debugger/view/stepper.ss index 1226e11319..41b44b8ac3 100644 --- a/collects/macro-debugger/view/stepper.ss +++ b/collects/macro-debugger/view/stepper.ss @@ -427,10 +427,15 @@ (define/private (adjust-deriv/lift deriv) (match deriv [(Wrap lift-deriv (e1 e2 first lifted-stx second)) - (let ([first (adjust-deriv/top first)]) + (let ([first (adjust-deriv/lift first)]) (and first (let ([e1 (wderiv-e1 first)]) (make-lift-deriv e1 e2 first lifted-stx second))))] + [(Wrap ecte (e1 e2 first second)) + (let ([first (adjust-deriv/lift first)]) + (and first + (let ([e1 (wderiv-e1 first)]) + (make ecte e1 e2 first second))))] [else (adjust-deriv/top deriv)])) ;; adjust-deriv/top : Derivation -> Derivation @@ -442,18 +447,10 @@ ;; It's not original... ;; Strip out mzscheme's top-interactions ;; Keep anything that is a non-mzscheme top-interaction - ;; Drop everything else (not original program) - (cond [(not (mrule? deriv)) #f] - [(for/or ([x (base-resolves deriv)]) (top-interaction-kw? x)) + (cond [(for/or ([x (base-resolves deriv)]) (top-interaction-kw? x)) ;; Just mzscheme's top-interaction; strip it out (adjust-deriv/top (mrule-next deriv))] - [(equal? (map syntax-e (base-resolves deriv)) - '(#%top-interaction)) - ;; A *different* top interaction; keep it - deriv] - [else - ;; Not original and not tagged with top-interaction - #f]))) + [else deriv]))) (define/public (top-interaction-kw? x) (or (free-identifier=? x #'#%top-interaction) diff --git a/collects/tests/macro-debugger/test-setup.ss b/collects/tests/macro-debugger/test-setup.ss index 8ca59c2eea..7c15611319 100644 --- a/collects/tests/macro-debugger/test-setup.ss +++ b/collects/tests/macro-debugger/test-setup.ss @@ -6,6 +6,9 @@ (provide trace/ns trace/t trace/k + + testing-namespace + hide-all-policy hide-none-policy @@ -24,9 +27,12 @@ (define (trace/k expr) (trace/ns expr #t)) +;; Use just 'expand', not 'expand/compile-time-evals', +;; for test backward compatibility +;; FIXME: add tests that use 'expand/compile-time-evals' (define (trace/ns expr kernel?) (parameterize ((current-namespace (choose-namespace kernel?))) - (trace expr))) + (trace expr expand))) (define (choose-namespace kernel?) (if kernel? kernel-namespace testing-namespace)) diff --git a/collects/tests/macro-debugger/tests/regression.ss b/collects/tests/macro-debugger/tests/regression.ss index 6758f6a87a..dc1e65363e 100644 --- a/collects/tests/macro-debugger/tests/regression.ss +++ b/collects/tests/macro-debugger/tests/regression.ss @@ -188,4 +188,19 @@ (trace `(module m mzscheme (require ',freshname) (meval (+ 1 2))))))) + + (test-case "macro def within begin" + (let ([rs (reductions + (trace '(begin + (define-syntax-rule (m x e) + (define x e)) + (m y 12))))]) + (check-pred list? rs) + (check-false (ormap misstep? rs)) + (check-true (for/or ([step rs]) + (equal? (syntax->datum (state-e (protostep-s1 step))) + '(m y 12)) + (equal? (syntax->datum (state-e (step-s2 step))) + '(define y 12))) + "looking for m => define"))) )) diff --git a/collects/tests/macro-debugger/tests/syntax-macros.ss b/collects/tests/macro-debugger/tests/syntax-macros.ss index 3df5d68234..fc7c263c21 100644 --- a/collects/tests/macro-debugger/tests/syntax-macros.ss +++ b/collects/tests/macro-debugger/tests/syntax-macros.ss @@ -44,7 +44,7 @@ (test "lift" (lift 'a) - [#:steps (local-lift #rx"^lifted" (lift 'a)) + [#:steps (local-lift (#rx"^lifted") (lift 'a)) (macro (#%expression #rx"^lifted")) (tag-top (#%expression (#%top . #rx"^lifted"))) (capture-lifts (begin (define-values (#rx"^lifted") 'a) @@ -53,7 +53,7 @@ #:no-hidden-steps) (test "lift with id" (lift (id 'a)) - [#:steps (local-lift #rx"^lifted" (lift (id 'a))) + [#:steps (local-lift (#rx"^lifted") (lift (id 'a))) (macro (#%expression #rx"^lifted")) (tag-top (#%expression (#%top . #rx"^lifted"))) (capture-lifts (begin (define-values (#rx"^lifted") (id 'a)) @@ -64,7 +64,7 @@ (test "lift with Tid" (lift (Tid 'a)) - [#:steps (local-lift #rx"^lifted" (lift (Tid 'a))) + [#:steps (local-lift (#rx"^lifted") (lift (Tid 'a))) (macro (#%expression #rx"^lifted")) (tag-top (#%expression (#%top . #rx"^lifted"))) (capture-lifts (begin (define-values (#rx"^lifted") (Tid 'a)) @@ -76,40 +76,40 @@ (test "Tlift" (Tlift 'a) - [#:steps (local-lift #rx"^lifted" (Tlift 'a)) + [#:steps (local-lift (#rx"^lifted") (Tlift 'a)) (macro (#%expression #rx"^lifted")) (tag-top (#%expression (#%top . #rx"^lifted"))) (capture-lifts (begin (define-values (#rx"^lifted") 'a) (#%expression (#%top . #rx"^lifted"))))] - [#:hidden-steps (local-lift #rx"^lifted" (Tlift 'a)) + [#:hidden-steps (local-lift (#rx"^lifted") (Tlift 'a)) (macro (#%expression #rx"^lifted")) (capture-lifts (begin (define-values (#rx"^lifted") 'a) (#%expression #rx"^lifted")))]) (test "Tlift with id" (Tlift (id 'a)) - [#:steps (local-lift #rx"^lifted" (Tlift (id 'a))) + [#:steps (local-lift (#rx"^lifted") (Tlift (id 'a))) (macro (#%expression #rx"^lifted")) (tag-top (#%expression (#%top . #rx"^lifted"))) (capture-lifts (begin (define-values (#rx"^lifted") (id 'a)) (#%expression (#%top . #rx"^lifted")))) (macro (begin (define-values (#rx"^lifted") 'a) (#%expression (#%top . #rx"^lifted"))))] - [#:hidden-steps (local-lift #rx"^lifted" (Tlift (id 'a))) + [#:hidden-steps (local-lift (#rx"^lifted") (Tlift (id 'a))) (macro (#%expression #rx"^lifted")) (capture-lifts (begin (define-values (#rx"^lifted") (id 'a)) (#%expression #rx"^lifted")))]) (test "Tlift with Tid" (Tlift (Tid 'a)) - [#:steps (local-lift #rx"^lifted" (Tlift (Tid 'a))) + [#:steps (local-lift (#rx"^lifted") (Tlift (Tid 'a))) (macro (#%expression #rx"^lifted")) (tag-top (#%expression (#%top . #rx"^lifted"))) (capture-lifts (begin (define-values (#rx"^lifted") (Tid 'a)) (#%expression (#%top . #rx"^lifted")))) (macro (begin (define-values (#rx"^lifted") 'a) (#%expression (#%top . #rx"^lifted"))))] - [#:steps (local-lift #rx"^lifted" (Tlift (Tid 'a))) + [#:steps (local-lift (#rx"^lifted") (Tlift (Tid 'a))) (macro (#%expression #rx"^lifted")) (capture-lifts (begin (define-values (#rx"^lifted") (Tid 'a)) (#%expression #rx"^lifted")))