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

updated macro debugger to work with begin-for-syntax changes

Browse Source 
Also cleaned up support for lazy instantiation of phase>0
environments.

original commit: 30d5381e98c360aba7fb7026bfbeb7378e09e19d
This commit is contained in:
Ryan Culpepper 2011-09-08 20:41:23 -06:00
commit 02cc0920fc
7 changed files with 199 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
collects/macro-debugger/analysis/check-requires.rkt
View File

@ -116,6 +116,9 @@ The limitations:
(if (list? arg)
(apply recur arg)
(analyze arg refs))))
(define (recur/phase-up . args)
(parameterize ((phase (add1 (phase))))
(apply recur args)))
(define (add! ids)
(reftable-add-all! refs (phase) ids))
@ -147,8 +150,7 @@ The limitations:
[(local-exn exn)
(void)]
[(local-expansion z1 z2 for-stx? me1 inner lifted me2 opaque)
(parameterize ((phase (+ (phase) (if for-stx? 1 0))))
(recur inner))]
((if for-stx? recur/phase-up recur) inner)]
[(local-lift expr ids)
(void)]
[(local-lift-end decl)
@ -171,13 +173,16 @@ The limitations:
(void)]
[(p:module z1 z2 rs ?1 locals tag rename check tag2 ?3 body shift)
(recur locals check body)]
[(p:#%module-begin z1 z2 rs ?1 me pass1 pass2 ?2)
(recur pass1 pass2)]
[(p:define-syntaxes z1 z2 rs ?1 rhs locals)
(parameterize ((phase (+ (phase) 1)))
(recur rhs locals))]
[(p:#%module-begin z1 z2 rs ?1 me body ?2)
(recur body)]
[(p:define-syntaxes z1 z2 rs ?1 prep rhs locals)
(recur prep locals)
(recur/phase-up rhs)]
[(p:define-values z1 z2 rs ?1 rhs)
(recur rhs)]
[(p:begin-for-syntax z1 z2 rs ?1 prep body)
(recur prep)
(recur/phase-up body)]
[(p:#%expression z1 z2 rs ?1 inner untag)
(recur inner)]
@ -205,8 +210,8 @@ The limitations:
(recur rhss body)]
[(p:letrec-values _ _ _ _ renames rhss body)
(recur rhss body)]
[(p:letrec-syntaxes+values _ _ _ _ srenames sbindrhss vrenames vrhss body tag)
(recur sbindrhss vrhss body)]
[(p:letrec-syntaxes+values _ _ _ _ srenames prep sbindrhss vrenames vrhss body tag)
(recur prep sbindrhss vrhss body)]
[(p:provide _ _ _ _ inners ?2)
(recur inners)]
@ -226,7 +231,6 @@ The limitations:
[(p:quote-syntax z1 z2 _ _)
(when z2 (analyze/quote-syntax z2 refs))]
[(p:#%variable-reference _ _ _ _)
;; FIXME
(void)]
[(lderiv _ _ ?1 derivs)
@ -243,16 +247,19 @@ The limitations:
(recur head)]
[(b:defvals _ head ?1 rename ?2)
(recur head)]
[(b:defstx _ head ?1 rename ?2 bindrhs)
(recur head bindrhs)]
[(b:defstx _ head ?1 rename ?2 prep bindrhs)
(recur head prep bindrhs)]
[(bind-syntaxes rhs locals)
(parameterize ((phase (+ 1 (phase))))
(recur rhs locals))]
(recur/phase-up rhs)
(recur locals)]
[(clc ?1 renames body)
(recur body)]
[(module-begin/phase pass1 pass2 pass3)
(recur pass1 pass2 pass3)]
[(mod:prim head rename prim)
(recur head prim)]
[(mod:splice head rename ?1 tail)
@ -266,8 +273,12 @@ The limitations:
[(mod:skip)
(void)]
;; Shouldn't occur in module expansion.
;; (Unless code calls 'expand' at compile-time; weird, but possible.)
[(ecte _ _ locals first second locals2)
(recur locals first second locals2)]
[(bfs:lift lderiv lifts)
(recur lderiv)]
[#f
(void)]))

8
collects/macro-debugger/analysis/private/moduledb.rkt
View File

@ -21,7 +21,7 @@
[racket/match no-bypass]
['#%builtin no-drop]
[typed-scheme/private/base-env no-drop]
[typed-scheme/private/base-special-env no-drop]
[typed-scheme/private/base-env-numeric no-drop]
[typed-scheme/private/base-env-indexing no-drop])))
[typed-racket/private/base-env no-drop]
[typed-racket/private/base-special-env no-drop]
[typed-racket/private/base-env-numeric no-drop]
[typed-racket/private/base-env-indexing no-drop])))

49
collects/macro-debugger/model/deriv-c.rkt
View File

@ -1,6 +1,8 @@
#lang racket/base
(provide (all-defined-out))
;; PrepareExpEnv = (listof LocalAction)
;; A Node(a) is:
;; (make-node a ?a)
(define-struct node (z1 z2) #:transparent)
@ -48,15 +50,15 @@
(define-struct (prule base) () #:transparent)
(define-struct (p:variable prule) () #:transparent)
;; (make-p:module <Base> (listof LocalAction) ?stx stx ?Deriv ?stx ?exn Deriv ?stx)
;; (make-p:#%module-begin <Base> Stx ModulePass1 ModulePass2 ?exn)
(define-struct (p:module prule) (locals tag rename check tag2 ?3 body shift)
;; (make-p:module <Base> PrepareEnv ?stx stx ?Deriv ?stx ?exn Deriv ?stx)
;; (make-p:#%module-begin <Base> Stx ModuleBegin/Phase ?exn)
(define-struct (p:module prule) (prep tag rename check tag2 ?3 body shift)
#:transparent)
(define-struct (p:#%module-begin prule) (me pass1 pass2 ?2) #:transparent)
(define-struct (p:#%module-begin prule) (me body ?2) #:transparent)
;; (make-p:define-syntaxes <Base> DerivLL (listof LocalAction))
;; (make-p:define-syntaxes <Base> (listof LocalAction) DerivLL (listof LocalAction))
;; (make-p:define-values <Base> Deriv)
(define-struct (p:define-syntaxes prule) (rhs locals) #:transparent)
(define-struct (p:define-syntaxes prule) (prep rhs locals) #:transparent)
(define-struct (p:define-values prule) (rhs) #:transparent)
;; (make-p:#%expression <Base> Deriv ?Stx)
@ -81,13 +83,14 @@
;; (make-p:case-lambda <Base> (list-of CaseLambdaClause))
;; (make-p:let-values <Base> LetRenames (list-of Deriv) BDeriv)
;; (make-p:letrec-values <Base> LetRenames (list-of Deriv) BDeriv)
;; (make-p:letrec-syntaxes+values <Base> LSVRenames (list-of BindSyntaxes) (list-of Deriv) BDeriv ?Stx)
;; (make-p:letrec-syntaxes+values <Base> LSVRenames PrepareExpEnv
;; (list-of BindSyntaxes) (list-of Deriv) BDeriv ?Stx)
(define-struct (p:lambda prule) (renames body) #:transparent)
(define-struct (p:case-lambda prule) (renames+bodies) #:transparent)
(define-struct (p:let-values prule) (renames rhss body) #:transparent)
(define-struct (p:letrec-values prule) (renames rhss body) #:transparent)
(define-struct (p:letrec-syntaxes+values prule)
(srenames sbindrhss vrenames vrhss body tag)
(srenames prep sbindrhss vrenames vrhss body tag)
#:transparent)
;; (make-p:provide <Base> (listof Deriv) ?exn)
@ -99,6 +102,12 @@
;; (make-p:#%stratified-body <Base> BDeriv)
(define-struct (p:#%stratified-body prule) (bderiv) #:transparent)
;; (make-p:begin-for-syntax <base> (listof LocalAction) BFSBody)
;; where BFSBody is one of
;; - ModuleBegin/Phase
;; - (list BeginForSyntaxLifts ... LDeriv))
(define-struct (p:begin-for-syntax prule) (prep body) #:transparent)
;; (make-p:stop <Base>)
;; (make-p:unknown <Base>)
;; (make-p:#%top <Base> Stx)
@ -129,13 +138,13 @@
;; (make-b:expr BlockRenames Deriv)
;; (make-b:splice BlockRenames Deriv ?exn Stxs ?exn)
;; (make-b:defvals BlockRenames Deriv ?exn Stx ?exn)
;; (make-b:defstx BlockRenames Deriv ?exn Stx ?exn BindSyntaxes)
;; (make-b:defstx BlockRenames Deriv ?exn Stx ?exn PrepareExpEnv BindSyntaxes)
(define-struct b:error (?1) #:transparent)
(define-struct brule (renames) #:transparent)
(define-struct (b:expr brule) (head) #:transparent)
(define-struct (b:splice brule) (head ?1 tail ?2) #:transparent)
(define-struct (b:defvals brule) (head ?1 rename ?2) #:transparent)
(define-struct (b:defstx brule) (head ?1 rename ?2 bindrhs) #:transparent)
(define-struct (b:defstx brule) (head ?1 rename ?2 prep bindrhs) #:transparent)
;; A BindSyntaxes is
;; (make-bind-syntaxes DerivLL (listof LocalAction))
@ -147,8 +156,16 @@
;; A BlockRename is (cons Stx Stx)
;; A BeginForSyntaxLifts is
;; (make-bfs:lift LDeriv (listof stx))
(define-struct bfs:lift (lderiv lifts) #:transparent)
;; A ModuleBegin/Phase is (module-begin/phase ModulePass1 ModulePass2 ModulePass3)
(define-struct module-begin/phase (pass1 pass2 pass3) #:transparent)
;; A ModPass1 is (list-of ModRule1)
;; A ModPass2 is (list-of ModRule2)
;; A ModPass3 is (list-of p:provide)
;; A ModRule1 is one of
;; (make-mod:prim Deriv Stx ModPrim)
@ -167,12 +184,12 @@
(define-struct (mod:cons modrule) (head) #:transparent)
(define-struct (mod:skip modrule) () #:transparent)
;; A ModPrim is a PRule in:
;; (make-p:define-values <Base> #:transparent)
;; (make-p:define-syntaxes <Base> Deriv)
;; (make-p:require <Base> (listof LocalAction))
;; (make-p:provide <Base>)
;; #f
;; A ModPrim is either #f or one of the following PRule variants:
;; - p:define-values
;; - p:define-syntaxes
;; - p:begin-for-syntax
;; - p:require
;; - p:provide
;; ECTE represents expand/compile-time-evals

87
collects/macro-debugger/model/deriv-parser.rkt
View File

@ -28,9 +28,9 @@
(parser
(options (start Expansion)
(src-pos)
(tokens basic-tokens prim-tokens renames-tokens)
(tokens basic-empty-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
@ -55,7 +55,8 @@
tag
IMPOSSIBLE
start
top-non-begin)
top-non-begin
prepare-env)
;; Entry point
(productions
@ -119,6 +120,10 @@
(Eval
[((? LocalActions)) $1])
;; Prepare env for compilation
(PrepareEnv
[(prepare-env (? Eval)) $2])
;; Expansion of an expression to primitive form
(CheckImmediateMacro
[(enter-check (? CheckImmediateMacro/Inner) exit-check)
@ -198,9 +203,9 @@
(make local-lift-require (car $1) (cadr $1) (cddr $1))]
[(lift-provide)
(make local-lift-provide $1)]
[(local-bind ! rename-list)
[(local-bind ! rename-list next)
(make local-bind $1 $2 $3 #f)]
[(local-bind rename-list (? BindSyntaxes))
[(local-bind rename-list (? BindSyntaxes) next)
(make local-bind $1 #f $2 $3)]
[(track-origin)
(make track-origin (car $1) (cdr $1))]
@ -266,14 +271,15 @@
[((? PrimRequire)) ($1 e1 e2 rs)]
[((? PrimProvide)) ($1 e1 e2 rs)]
[((? PrimVarRef)) ($1 e1 e2 rs)]
[((? PrimStratifiedBody)) ($1 e1 e2 rs)])
[((? PrimStratifiedBody)) ($1 e1 e2 rs)]
[((? PrimBeginForSyntax)) ($1 e1 e2 rs)])
(PrimModule
(#:args e1 e2 rs)
[(prim-module ! next (? Eval) OptTag rename-one
[(prim-module ! (? PrepareEnv) OptTag rename-one
(? OptCheckImmediateMacro) OptTag !
(? EE) rename-one)
(make p:module e1 e2 rs $2 $4 $5 $6 $7 $8 $9 $10 $11)])
(make p:module e1 e2 rs $2 $3 $4 $5 $6 $7 $8 $9 $10)])
(OptTag
[() #f]
[(tag) $1])
@ -283,9 +289,12 @@
(Prim#%ModuleBegin
(#:args e1 e2 rs)
[(prim-#%module-begin ! rename-one
(? ModulePass1) next-group (? ModulePass2) !)
(make p:#%module-begin e1 e2 rs $2 $3 $4 $6 $7)])
[(prim-#%module-begin ! rename-one (? ModuleBegin/Phase) !)
(make p:#%module-begin e1 e2 rs $2 $3 $4 $5)])
(ModuleBegin/Phase
[((? ModulePass1) next-group (? ModulePass2) next-group (? ModulePass3))
(make module-begin/phase $1 $3 $5)])
(ModulePass1
(#:skipped null)
@ -307,17 +316,12 @@
(#:args e1)
[(enter-prim prim-define-values ! exit-prim)
(make p:define-values $1 $4 null $3 #f)]
[(enter-prim prim-define-syntaxes (? Eval)
[(enter-prim prim-define-syntaxes ! (? PrepareEnv)
phase-up (? EE/LetLifts) (? Eval) exit-prim)
;; FIXME: define-syntax can trigger instantiation of phase-1 code from other
;; modules. Ideally, should have [ ... prim-define-syntaxes ! (? Eval) ... ]
;; but gives shift/reduce conflict.
;; One solution: add 'next marker between form check and phase-1 init.
;; Also search for other places where phase-1 init can happen.
(let ([$3
(for/or ([local-action (in-list $3)])
(and (local-exn? local-action) (local-exn-exn local-action)))])
(make p:define-syntaxes $1 $7 null $3 $5 $6))]
(make p:define-syntaxes $1 $8 null $3 $4 $6 $7)]
[(enter-prim prim-begin-for-syntax ! (? PrepareEnv)
phase-up (? ModuleBegin/Phase) exit-prim)
(make p:begin-for-syntax $1 $7 null $3 $4 $6)]
[(enter-prim prim-require (? Eval) exit-prim)
(make p:require $1 $4 null #f $3)]
[()
@ -335,9 +339,6 @@
;; not normal; already handled
[()
(make mod:skip)]
;; provide: special
[(enter-prim prim-provide (? ModuleProvide/Inner) ! exit-prim)
(make mod:cons (make p:provide $1 $5 null #f $3 $4))]
;; normal: expand completely
[((? EE))
(make mod:cons $1)]
@ -345,6 +346,16 @@
[(EE module-lift-loop)
(make mod:lift $1 #f $2)])
(ModulePass3
(#:skipped null)
[() null]
[((? ModulePass3-Part) (? ModulePass3))
(cons $1 $2)])
(ModulePass3-Part
[(enter-prim prim-provide (? ModuleProvide/Inner) ! exit-prim)
(make p:provide $1 $5 null #f $3 $4)])
(ModuleProvide/Inner
(#:skipped null)
[() null]
@ -354,8 +365,8 @@
;; Definitions
(PrimDefineSyntaxes
(#:args e1 e2 rs)
[(prim-define-syntaxes ! (? EE/LetLifts) (? Eval))
(make p:define-syntaxes e1 e2 rs $2 $3 $4)])
[(prim-define-syntaxes ! (? PrepareEnv) (? EE/LetLifts) (? Eval))
(make p:define-syntaxes e1 e2 rs $2 $3 $4 $5)])
(PrimDefineValues
(#:args e1 e2 rs)
@ -444,13 +455,13 @@
(PrimLetrecSyntaxes+Values
(#:args e1 e2 rs)
[(prim-letrec-syntaxes+values ! renames-letrec-syntaxes
(? NextBindSyntaxess) next-group (? EB) OptTag)
(make p:letrec-syntaxes+values e1 e2 rs $2 $3 $4 #f null $6 $7)]
[(prim-letrec-syntaxes+values renames-letrec-syntaxes
NextBindSyntaxess next-group
(? PrepareEnv) (? NextBindSyntaxess) next-group (? EB) OptTag)
(make p:letrec-syntaxes+values e1 e2 rs $2 $3 $4 $5 #f null $7 $8)]
[(prim-letrec-syntaxes+values renames-letrec-syntaxes
PrepareEnv NextBindSyntaxess next-group
prim-letrec-values
renames-let (? NextEEs) next-group (? EB) OptTag)
(make p:letrec-syntaxes+values e1 e2 rs #f $2 $3 $6 $7 $9 $10)])
(make p:letrec-syntaxes+values e1 e2 rs #f $2 $3 $4 $7 $8 $10 $11)])
;; Atomic expressions
(Prim#%Datum
@ -490,6 +501,16 @@
(#:args e1 e2 rs)
[(prim-#%stratified-body ! (? EB)) (make p:#%stratified-body e1 e2 rs $2 $3)])
(PrimBeginForSyntax
(#:args e1 e2 rs)
[(prim-begin-for-syntax ! (? PrepareEnv) (? BeginForSyntax*))
(make p:begin-for-syntax e1 e2 rs $2 $3 $4)])
(BeginForSyntax*
[((? EL))
(list $1)]
[(EL module-lift-loop (? BeginForSyntax*))
(cons (make bfs:lift $1 $2) $3)])
(PrimSet
(#:args e1 e2 rs)
;; Unrolled to avoid shift/reduce
@ -526,8 +547,8 @@
[(next renames-block CheckImmediateMacro prim-define-values ! rename-one !)
(make b:defvals $2 $3 $5 $6 $7)]
[(next renames-block CheckImmediateMacro
prim-define-syntaxes ! rename-one ! (? BindSyntaxes))
(make b:defstx $2 $3 $5 $6 $7 $8)])
prim-define-syntaxes ! rename-one ! (? PrepareEnv) (? BindSyntaxes))
(make b:defstx $2 $3 $5 $6 $7 $8 $9)])
;; BindSyntaxes Answer = Derivation
(BindSyntaxes

31
collects/macro-debugger/model/deriv-tokens.rkt
View File

@ -3,12 +3,24 @@
"deriv.rkt")
(provide (all-defined-out))
(define-tokens basic-tokens
(define-tokens basic-empty-tokens
(start ; .
visit ; syntax
resolve ; identifier
next ; .
next-group ; .
phase-up ; .
... ; .
EOF ; .
enter-bind ; .
exit-bind ; .
IMPOSSIBLE ; useful for error-handling clauses that have no
; NoError counterpart
top-non-begin ; .
prepare-env ; .
))
(define-tokens basic-tokens
(visit ; syntax
resolve ; identifier
enter-macro ; syntax
macro-pre-transform ; syntax
macro-post-transform ; syntax
@ -24,10 +36,7 @@
exit-list ; syntaxes
enter-check ; syntax
exit-check ; syntax
phase-up ; .
module-body ; (list-of (cons syntax boolean))
... ; .
EOF ; .
syntax-error ; exn
lift-loop ; syntax = new form (let or begin; let if for_stx)
lift/let-loop ; syntax = new let form
@ -44,8 +53,6 @@
exit-local ; syntax
local-bind ; (listof identifier)
enter-bind ; .
exit-bind ; .
opaque ; opaque-syntax
variable ; (cons identifier identifier)
@ -54,10 +61,7 @@
rename-one ; syntax
rename-list ; (list-of syntax)
IMPOSSIBLE ; useful for error-handling clauses that have no NoError counterpart
top-begin ; identifier
top-non-begin ; .
local-remark ; (listof (U string syntax))
local-artificial-step ; (list syntax syntax syntax syntax)
@ -88,6 +92,7 @@
prim-expression
prim-varref
prim-#%stratified-body
prim-begin-for-syntax
))
;; ** Signals to tokens
@ -182,7 +187,9 @@
(152 track-origin ,token-track-origin)
(153 local-value ,token-local-value)
(154 local-value-result ,token-local-value-result)
(155 prim-#%stratified-body)))
(155 prim-#%stratified-body)
(156 prim-begin-for-syntax)
(157 prepare-env)))
(define (signal->symbol sig)
(if (symbol? sig)

75
collects/macro-debugger/model/reductions.rkt
View File

@ -76,11 +76,11 @@
[#:when (or (not (identifier? e1))
(not (bound-identifier=? e1 e2)))
[#:walk e2 'resolve-variable]])]
[(Wrap p:module (e1 e2 rs ?1 locals tag rename check tag2 ?3 body shift))
[(Wrap p:module (e1 e2 rs ?1 prep tag rename check tag2 ?3 body shift))
(R [#:hide-check rs]
[! ?1]
[#:pattern ?form]
[LocalActions ?form locals]
[PrepareEnv ?form prep]
[#:pattern (?module ?name ?language . ?body-parts)]
[#:when tag
[#:in-hole ?body-parts
@ -98,19 +98,17 @@
[Expr ?body body]
[#:pattern ?form]
[#:rename ?form shift])]
[(Wrap p:#%module-begin (e1 e2 rs ?1 me pass1 pass2 ?2))
[(Wrap p:#%module-begin (e1 e2 rs ?1 me body ?2))
(R [! ?1]
[#:pattern ?form]
[#:rename ?form me]
[#:pattern (?module-begin . ?forms)]
[#:pass1]
[ModulePass ?forms pass1]
[#:pass2]
[#:do (DEBUG (printf "** module begin pass 2\n"))]
[ModulePass ?forms pass2]
[! ?1])]
[(Wrap p:define-syntaxes (e1 e2 rs ?1 rhs locals))
[ModuleBegin/Phase ?forms body]
[! ?2])]
[(Wrap p:define-syntaxes (e1 e2 rs ?1 prep rhs locals))
(R [! ?1]
[#:pattern ?form]
[PrepareEnv ?form prep]
[#:pattern (?define-syntaxes ?vars ?rhs)]
[#:binders #'?vars]
[Expr/PhaseUp ?rhs rhs]
@ -191,8 +189,10 @@
[Expr (?rhs ...) rhss]
[Block ?body body])]
[(Wrap p:letrec-syntaxes+values
(e1 e2 rs ?1 srenames srhss vrenames vrhss body tag))
(e1 e2 rs ?1 srenames prep srhss vrenames vrhss body tag))
(R [! ?1]
[#:pattern ?form]
[PrepareEnv ?form prep]
[#:pass1]
[#:pattern (?lsv ([?svars ?srhs] ...) ([?vvars ?vrhs] ...) . ?body)]
[#:rename (((?svars ?srhs) ...) ((?vvars ?vrhs) ...) . ?body)
@ -271,6 +271,16 @@
[! ?2]
[Expr ?rhs rhs])]
[(Wrap p:begin-for-syntax (e1 e2 rs ?1 prep body))
(R [! ?1]
[#:pattern ?form]
[PrepareEnv ?form prep]
[#:pattern (?bfs . ?forms)]
[#:parameterize ((phase (add1 (phase))))
[#:if (module-begin/phase? body)
[[ModuleBegin/Phase ?forms body]]
[[BeginForSyntax ?forms body]]]])]
;; Macros
[(Wrap mrule (e1 e2 rs ?1 me1 locals me2 ?2 etx next))
(R [! ?1]
@ -378,6 +388,9 @@
[Block ?body body]
[CaseLambdaClauses ?rest rest])]))
(define (PrepareEnv prep)
(LocalActions prep))
;; local-actions-reductions
(define (LocalActions locals)
(match locals
@ -556,7 +569,7 @@
[#:pass2]
[#:pattern (?first . ?rest)]
[BlockPass ?rest rest])]
[(cons (Wrap b:defstx (renames head ?1 rename ?2 bindrhs)) rest)
[(cons (Wrap b:defstx (renames head ?1 rename ?2 prep bindrhs)) rest)
(R [#:pattern (?first . ?rest)]
[#:rename/no-step ?first (car renames) (cdr renames)]
[#:pass1]
@ -567,6 +580,8 @@
[#:binders #'?vars]
[! ?2]
[#:pass2]
[#:pattern ?form]
[PrepareEnv ?form prep]
[#:pattern ((?define-syntaxes ?vars ?rhs) . ?rest)]
[BindSyntaxes ?rhs bindrhs]
[#:pattern (?first . ?rest)]
@ -587,6 +602,42 @@
[Expr/PhaseUp ?form rhs]
[LocalActions ?form locals])]))
(define (BeginForSyntax passes)
;; Note: an lderiv doesn't necessarily cover all stxs, due to lifting.
(match/count passes
[(cons (? lderiv? lderiv) '())
(R [#:pattern ?forms]
[List ?forms lderiv])]
[(cons (Wrap bfs:lift (lderiv stxs)) rest)
(R [#:pattern LDERIV]
[#:parameterize ((available-lift-stxs (reverse stxs))
(visible-lift-stxs null))
[#:pass1]
[List LDERIV lderiv]
[#:do (when (pair? (available-lift-stxs))
(lift-error 'bfs:lift "available lifts left over"))]
[#:let visible-lifts (visible-lift-stxs)]
[#:pattern ?forms]
[#:pass2]
[#:let old-forms #'?forms]
[#:left-foot null]
[#:set-syntax (append visible-lifts old-forms)]
[#:step 'splice-lifts visible-lifts]
[#:set-syntax (append stxs old-forms)]
[BeginForSyntax ?forms rest]])]))
(define (ModuleBegin/Phase body)
(match/count body
[(Wrap module-begin/phase (pass1 pass2 pass3))
(R [#:pass1]
[#:pattern ?forms]
[ModulePass ?forms pass1]
[#:pass2]
[#:do (DEBUG (printf "** module begin pass 2\n"))]
[ModulePass ?forms pass2]
;; ignore pass3 for now: only provides
)]))
;; ModulePass : (list-of MBRule) -> RST
(define (ModulePass mbrules)
(match/count mbrules

2
collects/macro-debugger/model/trace.rkt
View File

@ -152,7 +152,7 @@
(eval/compile stx)]
[(define-syntaxes . _)
(eval/compile stx)]
[(define-values-for-syntax . _)
[(begin-for-syntax . _)
(eval/compile stx)]
[(define-values (id ...) . _)
(with-syntax ([defvals (stx-car stx)]