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

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

@ -21,7 +21,7 @@
[racket/match no-bypass] [racket/match no-bypass]
['#%builtin no-drop] ['#%builtin no-drop]
[typed-scheme/private/base-env no-drop] [typed-racket/private/base-env no-drop]
[typed-scheme/private/base-special-env no-drop] [typed-racket/private/base-special-env no-drop]
[typed-scheme/private/base-env-numeric no-drop] [typed-racket/private/base-env-numeric no-drop]
[typed-scheme/private/base-env-indexing 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 #lang racket/base
(provide (all-defined-out)) (provide (all-defined-out))
;; PrepareExpEnv = (listof LocalAction)
;; A Node(a) is: ;; A Node(a) is:
;; (make-node a ?a) ;; (make-node a ?a)
(define-struct node (z1 z2) #:transparent) (define-struct node (z1 z2) #:transparent)
@ -48,15 +50,15 @@
(define-struct (prule base) () #:transparent) (define-struct (prule base) () #:transparent)
(define-struct (p:variable prule) () #:transparent) (define-struct (p:variable prule) () #:transparent)
;; (make-p:module <Base> (listof LocalAction) ?stx stx ?Deriv ?stx ?exn Deriv ?stx) ;; (make-p:module <Base> PrepareEnv ?stx stx ?Deriv ?stx ?exn Deriv ?stx)
;; (make-p:#%module-begin <Base> Stx ModulePass1 ModulePass2 ?exn) ;; (make-p:#%module-begin <Base> Stx ModuleBegin/Phase ?exn)
(define-struct (p:module prule) (locals tag rename check tag2 ?3 body shift) (define-struct (p:module prule) (prep tag rename check tag2 ?3 body shift)
#:transparent) #: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) ;; (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) (define-struct (p:define-values prule) (rhs) #:transparent)
;; (make-p:#%expression <Base> Deriv ?Stx) ;; (make-p:#%expression <Base> Deriv ?Stx)
@ -81,13 +83,14 @@
;; (make-p:case-lambda <Base> (list-of CaseLambdaClause)) ;; (make-p:case-lambda <Base> (list-of CaseLambdaClause))
;; (make-p:let-values <Base> LetRenames (list-of Deriv) BDeriv) ;; (make-p:let-values <Base> LetRenames (list-of Deriv) BDeriv)
;; (make-p:letrec-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:lambda prule) (renames body) #:transparent)
(define-struct (p:case-lambda prule) (renames+bodies) #:transparent) (define-struct (p:case-lambda prule) (renames+bodies) #:transparent)
(define-struct (p:let-values prule) (renames rhss body) #: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-values prule) (renames rhss body) #:transparent)
(define-struct (p:letrec-syntaxes+values prule) (define-struct (p:letrec-syntaxes+values prule)
(srenames sbindrhss vrenames vrhss body tag) (srenames prep sbindrhss vrenames vrhss body tag)
#:transparent) #:transparent)
;; (make-p:provide <Base> (listof Deriv) ?exn) ;; (make-p:provide <Base> (listof Deriv) ?exn)
@ -99,6 +102,12 @@
;; (make-p:#%stratified-body <Base> BDeriv) ;; (make-p:#%stratified-body <Base> BDeriv)
(define-struct (p:#%stratified-body prule) (bderiv) #:transparent) (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:stop <Base>)
;; (make-p:unknown <Base>) ;; (make-p:unknown <Base>)
;; (make-p:#%top <Base> Stx) ;; (make-p:#%top <Base> Stx)
@ -129,13 +138,13 @@
;; (make-b:expr BlockRenames Deriv) ;; (make-b:expr BlockRenames Deriv)
;; (make-b:splice BlockRenames Deriv ?exn Stxs ?exn) ;; (make-b:splice BlockRenames Deriv ?exn Stxs ?exn)
;; (make-b:defvals BlockRenames Deriv ?exn Stx ?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 b:error (?1) #:transparent)
(define-struct brule (renames) #:transparent) (define-struct brule (renames) #:transparent)
(define-struct (b:expr brule) (head) #:transparent) (define-struct (b:expr brule) (head) #:transparent)
(define-struct (b:splice brule) (head ?1 tail ?2) #:transparent) (define-struct (b:splice brule) (head ?1 tail ?2) #:transparent)
(define-struct (b:defvals brule) (head ?1 rename ?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 ;; A BindSyntaxes is
;; (make-bind-syntaxes DerivLL (listof LocalAction)) ;; (make-bind-syntaxes DerivLL (listof LocalAction))
@ -147,8 +156,16 @@
;; A BlockRename is (cons Stx Stx) ;; 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 ModPass1 is (list-of ModRule1)
;; A ModPass2 is (list-of ModRule2) ;; A ModPass2 is (list-of ModRule2)
;; A ModPass3 is (list-of p:provide)
;; A ModRule1 is one of ;; A ModRule1 is one of
;; (make-mod:prim Deriv Stx ModPrim) ;; (make-mod:prim Deriv Stx ModPrim)
@ -167,12 +184,12 @@
(define-struct (mod:cons modrule) (head) #:transparent) (define-struct (mod:cons modrule) (head) #:transparent)
(define-struct (mod:skip modrule) () #:transparent) (define-struct (mod:skip modrule) () #:transparent)
;; A ModPrim is a PRule in: ;; A ModPrim is either #f or one of the following PRule variants:
;; (make-p:define-values <Base> #:transparent) ;; - p:define-values
;; (make-p:define-syntaxes <Base> Deriv) ;; - p:define-syntaxes
;; (make-p:require <Base> (listof LocalAction)) ;; - p:begin-for-syntax
;; (make-p:provide <Base>) ;; - p:require
;; #f ;; - p:provide
;; ECTE represents expand/compile-time-evals ;; ECTE represents expand/compile-time-evals

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

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

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

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

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

@ -76,11 +76,11 @@
[#:when (or (not (identifier? e1)) [#:when (or (not (identifier? e1))
(not (bound-identifier=? e1 e2))) (not (bound-identifier=? e1 e2)))
[#:walk e2 'resolve-variable]])] [#: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] (R [#:hide-check rs]
[! ?1] [! ?1]
[#:pattern ?form] [#:pattern ?form]
[LocalActions ?form locals] [PrepareEnv ?form prep]
[#:pattern (?module ?name ?language . ?body-parts)] [#:pattern (?module ?name ?language . ?body-parts)]
[#:when tag [#:when tag
[#:in-hole ?body-parts [#:in-hole ?body-parts
@ -98,19 +98,17 @@
[Expr ?body body] [Expr ?body body]
[#:pattern ?form] [#:pattern ?form]
[#:rename ?form shift])] [#: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] (R [! ?1]
[#:pattern ?form] [#:pattern ?form]
[#:rename ?form me] [#:rename ?form me]
[#:pattern (?module-begin . ?forms)] [#:pattern (?module-begin . ?forms)]
[#:pass1] [ModuleBegin/Phase ?forms body]
[ModulePass ?forms pass1] [! ?2])]
[#:pass2] [(Wrap p:define-syntaxes (e1 e2 rs ?1 prep rhs locals))
[#:do (DEBUG (printf "** module begin pass 2\n"))]
[ModulePass ?forms pass2]
[! ?1])]
[(Wrap p:define-syntaxes (e1 e2 rs ?1 rhs locals))
(R [! ?1] (R [! ?1]
[#:pattern ?form]
[PrepareEnv ?form prep]
[#:pattern (?define-syntaxes ?vars ?rhs)] [#:pattern (?define-syntaxes ?vars ?rhs)]
[#:binders #'?vars] [#:binders #'?vars]
[Expr/PhaseUp ?rhs rhs] [Expr/PhaseUp ?rhs rhs]
@ -191,8 +189,10 @@
[Expr (?rhs ...) rhss] [Expr (?rhs ...) rhss]
[Block ?body body])] [Block ?body body])]
[(Wrap p:letrec-syntaxes+values [(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] (R [! ?1]
[#:pattern ?form]
[PrepareEnv ?form prep]
[#:pass1] [#:pass1]
[#:pattern (?lsv ([?svars ?srhs] ...) ([?vvars ?vrhs] ...) . ?body)] [#:pattern (?lsv ([?svars ?srhs] ...) ([?vvars ?vrhs] ...) . ?body)]
[#:rename (((?svars ?srhs) ...) ((?vvars ?vrhs) ...) . ?body) [#:rename (((?svars ?srhs) ...) ((?vvars ?vrhs) ...) . ?body)
@ -271,6 +271,16 @@
[! ?2] [! ?2]
[Expr ?rhs rhs])] [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 ;; Macros
[(Wrap mrule (e1 e2 rs ?1 me1 locals me2 ?2 etx next)) [(Wrap mrule (e1 e2 rs ?1 me1 locals me2 ?2 etx next))
(R [! ?1] (R [! ?1]
@ -378,6 +388,9 @@
[Block ?body body] [Block ?body body]
[CaseLambdaClauses ?rest rest])])) [CaseLambdaClauses ?rest rest])]))
(define (PrepareEnv prep)
(LocalActions prep))
;; local-actions-reductions ;; local-actions-reductions
(define (LocalActions locals) (define (LocalActions locals)
(match locals (match locals
@ -556,7 +569,7 @@
[#:pass2] [#:pass2]
[#:pattern (?first . ?rest)] [#:pattern (?first . ?rest)]
[BlockPass ?rest 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)] (R [#:pattern (?first . ?rest)]
[#:rename/no-step ?first (car renames) (cdr renames)] [#:rename/no-step ?first (car renames) (cdr renames)]
[#:pass1] [#:pass1]
@ -567,6 +580,8 @@
[#:binders #'?vars] [#:binders #'?vars]
[! ?2] [! ?2]
[#:pass2] [#:pass2]
[#:pattern ?form]
[PrepareEnv ?form prep]
[#:pattern ((?define-syntaxes ?vars ?rhs) . ?rest)] [#:pattern ((?define-syntaxes ?vars ?rhs) . ?rest)]
[BindSyntaxes ?rhs bindrhs] [BindSyntaxes ?rhs bindrhs]
[#:pattern (?first . ?rest)] [#:pattern (?first . ?rest)]
@ -587,6 +602,42 @@
[Expr/PhaseUp ?form rhs] [Expr/PhaseUp ?form rhs]
[LocalActions ?form locals])])) [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 ;; ModulePass : (list-of MBRule) -> RST
(define (ModulePass mbrules) (define (ModulePass mbrules)
(match/count mbrules (match/count mbrules

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

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