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

macro-stepper:

Browse Source 
do compile-time evals when expanding
    fixes: (begin macro-def macro-use) pattern
  updated tests for lifts change

svn: r16762
This commit is contained in:
Ryan Culpepper 2009-11-13 21:41:01 +00:00
parent 0d6da8957a
commit 32e38ca0e4
10 changed files with 172 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/macro-debugger/model/deriv-c.ss
View File

@ -170,3 +170,9 @@
;; (make-p:require-for-template <Base>) ;; (make-p:require-for-template <Base>)
;; (make-p:provide <Base>) ;; (make-p:provide <Base>)
;; #f ;; #f
;; ECTE represents expand/compile-time-evals
;; (make-ecte stx ?stx Deriv Deriv)
(define-struct (ecte deriv) (first second) #:transparent)

38
collects/macro-debugger/model/deriv-parser.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base #lang scheme/base
(require (for-syntax scheme/base) (require (for-syntax scheme/base)
syntax/stx
"yacc-ext.ss" "yacc-ext.ss"
"yacc-interrupted.ss" "yacc-interrupted.ss"
"deriv.ss" "deriv.ss"
@ -38,7 +39,7 @@
(src-pos) (src-pos)
(tokens basic-tokens prim-tokens renames-tokens) (tokens basic-tokens prim-tokens renames-tokens)
(end EOF) (end EOF)
#;(debug "/tmp/ryan/DEBUG-PARSER.txt") #|(debug "/tmp/ryan/DEBUG-PARSER.txt")|#
(error deriv-error)) (error deriv-error))
;; tokens ;; tokens
@ -60,16 +61,47 @@
rename-one rename-one
rename-list rename-list
tag tag
IMPOSSIBLE) IMPOSSIBLE
start
top-non-begin)
;; Entry point ;; Entry point
(productions (productions
(Expansion (Expansion
[(start EE/Lifts) $2] [(start EE/Lifts) $2]
[(start EE/Lifts/Interrupted) $2])) [(start EE/Lifts/Interrupted) $2]
[(start ExpandCTE) $2]
[(start ExpandCTE/Interrupted) $2]))
(productions/I (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 ;; Expand with possible lifting
(EE/Lifts (EE/Lifts
[((? EE)) $1] [((? EE)) $1]

11
collects/macro-debugger/model/deriv-tokens.ss
View File

@ -56,6 +56,9 @@
rename-list ; (list-of syntax) rename-list ; (list-of syntax)
IMPOSSIBLE ; useful for error-handling clauses that have no NoError counterpart IMPOSSIBLE ; useful for error-handling clauses that have no NoError counterpart
top-begin ; identifier
top-non-begin ; .
)) ))
(define-tokens renames-tokens (define-tokens renames-tokens
@ -160,6 +163,14 @@
(149 . prim-varref) (149 . prim-varref)
(150 . ,token-lift-require) (150 . ,token-lift-require)
(151 . ,token-lift-provide) (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) (define (tokenize sig-n val pos)

9
collects/macro-debugger/model/reductions.ss
View File

@ -271,6 +271,15 @@
(error 'reductions "unknown tagged syntax: ~s" tagged-stx)))] (error 'reductions "unknown tagged syntax: ~s" tagged-stx)))]
[Expr ?form next])] [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 ;; Lifts
[(Wrap lift-deriv (e1 e2 first lifted-stx second)) [(Wrap lift-deriv (e1 e2 first lifted-stx second))

77
collects/macro-debugger/model/trace.ss
View File

@ -12,6 +12,7 @@
trace-verbose? trace-verbose?
events->token-generator events->token-generator
current-expand-observe current-expand-observe
expand/compile-time-evals
trace-macro-limit trace-macro-limit
trace-limit-handler) trace-limit-handler)
@ -22,18 +23,18 @@
(define trace-verbose? (make-parameter #f)) (define trace-verbose? (make-parameter #f))
;; trace : stx -> Deriv ;; trace : stx -> Deriv
(define (trace stx) (define (trace stx [expander expand/compile-time-evals])
(let-values ([(result events derivp) (trace* stx expand)]) (let-values ([(result events derivp) (trace* stx expander)])
(force derivp))) (force derivp)))
;; trace/result : stx -> stx/exn Deriv ;; trace/result : stx -> stx/exn Deriv
(define (trace/result stx) (define (trace/result stx [expander expand/compile-time-evals])
(let-values ([(result events derivp) (trace* stx expand)]) (let-values ([(result events derivp) (trace* stx expander)])
(values result (values result
(force derivp)))) (force derivp))))
;; trace* : stx (stx -> stx) -> stx/exn (list-of event) (promise-of Deriv) ;; 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)]) (let-values ([(result events) (expand/events stx expander)])
(values result (values result
events events
@ -70,7 +71,7 @@
(if (and limit handler (exact-positive-integer? limit)) (if (and limit handler (exact-positive-integer? limit))
(lambda (x y) (lambda (x y)
(add! x y) (add! x y)
(when (= x 8) ;; enter-macro (when (eqv? x 8) ;; enter-macro
(set! counter (add1 counter)) (set! counter (add1 counter))
(when (= counter limit) (when (= counter limit)
(set! limit (handler counter))))) (set! limit (handler counter)))))
@ -85,3 +86,67 @@
(add! 'EOF #f) (add! 'EOF #f)
(values result (values result
(reverse events))))) (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)]))

2
collects/macro-debugger/tool.ss
View File

@ -244,7 +244,7 @@
(parameterize ((trace-macro-limit (pref:macro-step-limit)) (parameterize ((trace-macro-limit (pref:macro-step-limit))
(trace-limit-handler (trace-limit-handler
(lambda (c) (handle-macro-limit c)))) (lambda (c) (handle-macro-limit c))))
(trace* expr expand))) (trace* expr)))
(define/private (handle-macro-limit c) (define/private (handle-macro-limit c)
(define option (define option

19
collects/macro-debugger/view/stepper.ss
View File

@ -427,10 +427,15 @@
(define/private (adjust-deriv/lift deriv) (define/private (adjust-deriv/lift deriv)
(match deriv (match deriv
[(Wrap lift-deriv (e1 e2 first lifted-stx second)) [(Wrap lift-deriv (e1 e2 first lifted-stx second))
(let ([first (adjust-deriv/top first)]) (let ([first (adjust-deriv/lift first)])
(and first (and first
(let ([e1 (wderiv-e1 first)]) (let ([e1 (wderiv-e1 first)])
(make-lift-deriv e1 e2 first lifted-stx second))))] (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)])) [else (adjust-deriv/top deriv)]))
;; adjust-deriv/top : Derivation -> Derivation ;; adjust-deriv/top : Derivation -> Derivation
@ -442,18 +447,10 @@
;; It's not original... ;; It's not original...
;; Strip out mzscheme's top-interactions ;; Strip out mzscheme's top-interactions
;; Keep anything that is a non-mzscheme top-interaction ;; Keep anything that is a non-mzscheme top-interaction
;; Drop everything else (not original program) (cond [(for/or ([x (base-resolves deriv)]) (top-interaction-kw? x))
(cond [(not (mrule? deriv)) #f]
[(for/or ([x (base-resolves deriv)]) (top-interaction-kw? x))
;; Just mzscheme's top-interaction; strip it out ;; Just mzscheme's top-interaction; strip it out
(adjust-deriv/top (mrule-next deriv))] (adjust-deriv/top (mrule-next deriv))]
[(equal? (map syntax-e (base-resolves deriv)) [else deriv])))
'(#%top-interaction))
;; A *different* top interaction; keep it
deriv]
[else
;; Not original and not tagged with top-interaction
#f])))
(define/public (top-interaction-kw? x) (define/public (top-interaction-kw? x)
(or (free-identifier=? x #'#%top-interaction) (or (free-identifier=? x #'#%top-interaction)

8
collects/tests/macro-debugger/test-setup.ss
View File

@ -6,6 +6,9 @@
(provide trace/ns (provide trace/ns
trace/t trace/t
trace/k trace/k
testing-namespace
hide-all-policy hide-all-policy
hide-none-policy hide-none-policy
@ -24,9 +27,12 @@
(define (trace/k expr) (define (trace/k expr)
(trace/ns expr #t)) (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?) (define (trace/ns expr kernel?)
(parameterize ((current-namespace (choose-namespace kernel?))) (parameterize ((current-namespace (choose-namespace kernel?)))
(trace expr))) (trace expr expand)))
(define (choose-namespace kernel?) (define (choose-namespace kernel?)
(if kernel? kernel-namespace testing-namespace)) (if kernel? kernel-namespace testing-namespace))

15
collects/tests/macro-debugger/tests/regression.ss
View File

@ -188,4 +188,19 @@
(trace `(module m mzscheme (trace `(module m mzscheme
(require ',freshname) (require ',freshname)
(meval (+ 1 2))))))) (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")))
)) ))

18
collects/tests/macro-debugger/tests/syntax-macros.ss
View File

@ -44,7 +44,7 @@
(test "lift" (test "lift"
(lift 'a) (lift 'a)
[#:steps (local-lift #rx"^lifted" (lift 'a)) [#:steps (local-lift (#rx"^lifted") (lift 'a))
(macro (#%expression #rx"^lifted")) (macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . #rx"^lifted"))) (tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (#rx"^lifted") 'a) (capture-lifts (begin (define-values (#rx"^lifted") 'a)
@ -53,7 +53,7 @@
#:no-hidden-steps) #:no-hidden-steps)
(test "lift with id" (test "lift with id"
(lift (id 'a)) (lift (id 'a))
[#:steps (local-lift #rx"^lifted" (lift (id 'a))) [#:steps (local-lift (#rx"^lifted") (lift (id 'a)))
(macro (#%expression #rx"^lifted")) (macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . #rx"^lifted"))) (tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (#rx"^lifted") (id 'a)) (capture-lifts (begin (define-values (#rx"^lifted") (id 'a))
@ -64,7 +64,7 @@
(test "lift with Tid" (test "lift with Tid"
(lift (Tid 'a)) (lift (Tid 'a))
[#:steps (local-lift #rx"^lifted" (lift (Tid 'a))) [#:steps (local-lift (#rx"^lifted") (lift (Tid 'a)))
(macro (#%expression #rx"^lifted")) (macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . #rx"^lifted"))) (tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (#rx"^lifted") (Tid 'a)) (capture-lifts (begin (define-values (#rx"^lifted") (Tid 'a))
@ -76,40 +76,40 @@
(test "Tlift" (test "Tlift"
(Tlift 'a) (Tlift 'a)
[#:steps (local-lift #rx"^lifted" (Tlift 'a)) [#:steps (local-lift (#rx"^lifted") (Tlift 'a))
(macro (#%expression #rx"^lifted")) (macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . #rx"^lifted"))) (tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (#rx"^lifted") 'a) (capture-lifts (begin (define-values (#rx"^lifted") 'a)
(#%expression (#%top . #rx"^lifted"))))] (#%expression (#%top . #rx"^lifted"))))]
[#:hidden-steps (local-lift #rx"^lifted" (Tlift 'a)) [#:hidden-steps (local-lift (#rx"^lifted") (Tlift 'a))
(macro (#%expression #rx"^lifted")) (macro (#%expression #rx"^lifted"))
(capture-lifts (begin (define-values (#rx"^lifted") 'a) (capture-lifts (begin (define-values (#rx"^lifted") 'a)
(#%expression #rx"^lifted")))]) (#%expression #rx"^lifted")))])
(test "Tlift with id" (test "Tlift with id"
(Tlift (id 'a)) (Tlift (id 'a))
[#:steps (local-lift #rx"^lifted" (Tlift (id 'a))) [#:steps (local-lift (#rx"^lifted") (Tlift (id 'a)))
(macro (#%expression #rx"^lifted")) (macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . #rx"^lifted"))) (tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (#rx"^lifted") (id 'a)) (capture-lifts (begin (define-values (#rx"^lifted") (id 'a))
(#%expression (#%top . #rx"^lifted")))) (#%expression (#%top . #rx"^lifted"))))
(macro (begin (define-values (#rx"^lifted") 'a) (macro (begin (define-values (#rx"^lifted") 'a)
(#%expression (#%top . #rx"^lifted"))))] (#%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")) (macro (#%expression #rx"^lifted"))
(capture-lifts (begin (define-values (#rx"^lifted") (id 'a)) (capture-lifts (begin (define-values (#rx"^lifted") (id 'a))
(#%expression #rx"^lifted")))]) (#%expression #rx"^lifted")))])
(test "Tlift with Tid" (test "Tlift with Tid"
(Tlift (Tid 'a)) (Tlift (Tid 'a))
[#:steps (local-lift #rx"^lifted" (Tlift (Tid 'a))) [#:steps (local-lift (#rx"^lifted") (Tlift (Tid 'a)))
(macro (#%expression #rx"^lifted")) (macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . #rx"^lifted"))) (tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (#rx"^lifted") (Tid 'a)) (capture-lifts (begin (define-values (#rx"^lifted") (Tid 'a))
(#%expression (#%top . #rx"^lifted")))) (#%expression (#%top . #rx"^lifted"))))
(macro (begin (define-values (#rx"^lifted") 'a) (macro (begin (define-values (#rx"^lifted") 'a)
(#%expression (#%top . #rx"^lifted"))))] (#%expression (#%top . #rx"^lifted"))))]
[#:steps (local-lift #rx"^lifted" (Tlift (Tid 'a))) [#:steps (local-lift (#rx"^lifted") (Tlift (Tid 'a)))
(macro (#%expression #rx"^lifted")) (macro (#%expression #rx"^lifted"))
(capture-lifts (begin (define-values (#rx"^lifted") (Tid 'a)) (capture-lifts (begin (define-values (#rx"^lifted") (Tid 'a))
(#%expression #rx"^lifted"))) (#%expression #rx"^lifted")))