suzanne.soy/racket
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.
This commit is contained in:
Ryan Culpepper 2011-09-08 20:41:23 -06:00
parent 350c8214f8
commit 30d5381e98
9 changed files with 233 additions and 104 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)]))

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

16
src/racket/src/compile.c
View File

@ -3135,7 +3135,6 @@ single_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand_Info
form_name = SCHEME_STX_CAR(form); form_name = SCHEME_STX_CAR(form);
if (simplify && (erec[drec].depth == -1)) { if (simplify && (erec[drec].depth == -1)) {
/* FIXME [Ryan?]: this needs EXPAND_OBSERVE callbacks? */
expr = scheme_stx_track(expr, form, form_name); expr = scheme_stx_track(expr, form, form_name);
SCHEME_EXPAND_OBSERVE_TAG(erec[drec].observer,expr); SCHEME_EXPAND_OBSERVE_TAG(erec[drec].observer,expr);
return expr; return expr;
@ -3300,11 +3299,13 @@ define_syntaxes_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Ex
form = orig_form; form = orig_form;
scheme_define_parse(form, &names, &code, 1, env, 0);
SCHEME_EXPAND_OBSERVE_PREPARE_ENV(erec[drec].observer);
scheme_prepare_exp_env(env->genv); scheme_prepare_exp_env(env->genv);
scheme_prepare_compile_env(env->genv->exp_env); scheme_prepare_compile_env(env->genv->exp_env);
scheme_define_parse(form, &names, &code, 1, env, 0);
env = scheme_new_expand_env(env->genv->exp_env, env->insp, 0); env = scheme_new_expand_env(env->genv->exp_env, env->insp, 0);
erec[drec].value_name = names; erec[drec].value_name = names;
@ -3326,8 +3327,7 @@ begin_for_syntax_expand(Scheme_Object *orig_form, Scheme_Comp_Env *in_env, Schem
Scheme_Object *form, *context_key, *l, *fn, *vec, *dummy; Scheme_Object *form, *context_key, *l, *fn, *vec, *dummy;
Scheme_Comp_Env *env; Scheme_Comp_Env *env;
/* FIXME [Ryan?]: */ SCHEME_EXPAND_OBSERVE_PRIM_BEGIN_FOR_SYNTAX(rec[drec].observer);
/* SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(erec[drec].observer); */
form = orig_form; form = orig_form;
@ -3336,6 +3336,8 @@ begin_for_syntax_expand(Scheme_Object *orig_form, Scheme_Comp_Env *in_env, Schem
(void)check_form(form, form); (void)check_form(form, form);
SCHEME_EXPAND_OBSERVE_PREPARE_ENV(rec[drec].observer);
scheme_prepare_exp_env(in_env->genv); scheme_prepare_exp_env(in_env->genv);
scheme_prepare_compile_env(in_env->genv->exp_env); scheme_prepare_compile_env(in_env->genv->exp_env);
@ -3380,7 +3382,7 @@ begin_for_syntax_expand(Scheme_Object *orig_form, Scheme_Comp_Env *in_env, Schem
break; break;
} else { } else {
/* We have lifts: */ /* We have lifts: */
/* FIXME [Ryan?]: need some expand-observe callback here? */ SCHEME_EXPAND_OBSERVE_MODULE_LIFT_LOOP(rec[drec].observer, l);
} }
} }
@ -3803,6 +3805,7 @@ do_letrec_syntaxes(const char *where,
body = scheme_add_env_renames(body, stx_env, origenv); body = scheme_add_env_renames(body, stx_env, origenv);
SCHEME_EXPAND_OBSERVE_LETREC_SYNTAXES_RENAMES(rec[drec].observer, bindings, var_bindings, body); SCHEME_EXPAND_OBSERVE_LETREC_SYNTAXES_RENAMES(rec[drec].observer, bindings, var_bindings, body);
SCHEME_EXPAND_OBSERVE_PREPARE_ENV(rec[drec].observer);
scheme_prepare_exp_env(stx_env->genv); scheme_prepare_exp_env(stx_env->genv);
scheme_prepare_compile_env(stx_env->genv->exp_env); scheme_prepare_compile_env(stx_env->genv->exp_env);
@ -5706,6 +5709,7 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
if (!is_val) { if (!is_val) {
/* Evaluate and bind syntaxes */ /* Evaluate and bind syntaxes */
SCHEME_EXPAND_OBSERVE_PREPARE_ENV(rec[drec].observer);
scheme_prepare_exp_env(new_env->genv); scheme_prepare_exp_env(new_env->genv);
scheme_prepare_compile_env(new_env->genv->exp_env); scheme_prepare_compile_env(new_env->genv->exp_env);
pos = 0; pos = 0;

2
src/racket/src/eval.c
View File

@ -5172,6 +5172,8 @@ local_eval(int argc, Scheme_Object **argv)
if (!((void **)SCHEME_PTR1_VAL(argv[2]))[2]) if (!((void **)SCHEME_PTR1_VAL(argv[2]))[2])
((void **)SCHEME_PTR1_VAL(argv[2]))[2] = stx_env; ((void **)SCHEME_PTR1_VAL(argv[2]))[2] = stx_env;
SCHEME_EXPAND_OBSERVE_NEXT(observer);
return scheme_void; return scheme_void;
} }

24
src/racket/src/module.c
View File

@ -5713,7 +5713,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
self_modidx, self_modidx,
scheme_false); scheme_false);
SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer); SCHEME_EXPAND_OBSERVE_PREPARE_ENV(rec[drec].observer);
/* load the module for the initial require */ /* load the module for the initial require */
iim = module_load(_module_resolve(iidx, m->ii_src, NULL, 1), menv, NULL); iim = module_load(_module_resolve(iidx, m->ii_src, NULL, 1), menv, NULL);
@ -6669,7 +6669,11 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
/* For syntax-local-context, etc., in a d-s RHS: */ /* For syntax-local-context, etc., in a d-s RHS: */
rhs_env = scheme_new_comp_env(env->genv, env->insp, SCHEME_TOPLEVEL_FRAME); rhs_env = scheme_new_comp_env(env->genv, env->insp, SCHEME_TOPLEVEL_FRAME);
observer = rec[drec].observer; if (erec) {
observer = erec[derec].observer;
} else {
observer = NULL;
}
maybe_has_lifts = 0; maybe_has_lifts = 0;
lift_ctx = scheme_generate_lifts_key(); lift_ctx = scheme_generate_lifts_key();
@ -6710,7 +6714,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
erec1.comp = 0; erec1.comp = 0;
erec1.depth = -1; erec1.depth = -1;
erec1.value_name = scheme_false; erec1.value_name = scheme_false;
erec1.observer = rec[drec].observer; erec1.observer = observer;
erec1.pre_unwrapped = 0; erec1.pre_unwrapped = 0;
erec1.env_already = 0; erec1.env_already = 0;
erec1.comp_flags = rec[drec].comp_flags; erec1.comp_flags = rec[drec].comp_flags;
@ -6850,20 +6854,24 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
for_stx = scheme_stx_module_eq(begin_for_syntax_stx, fst, phase); for_stx = scheme_stx_module_eq(begin_for_syntax_stx, fst, phase);
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e); SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e);
SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(observer);
if (for_stx) { if (for_stx) {
SCHEME_EXPAND_OBSERVE_PRIM_BEGIN_FOR_SYNTAX(observer);
if (scheme_stx_proper_list_length(e) < 0) if (scheme_stx_proper_list_length(e) < 0)
scheme_wrong_syntax(NULL, NULL, e, NULL); scheme_wrong_syntax(NULL, NULL, e, NULL);
code = e; code = e;
} else } else {
SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(observer);
scheme_define_parse(e, &names, &code, 1, env, 1); scheme_define_parse(e, &names, &code, 1, env, 1);
}
if (!for_stx && SCHEME_STX_PAIRP(names) && SCHEME_STX_NULLP(SCHEME_STX_CDR(names))) if (!for_stx && SCHEME_STX_PAIRP(names) && SCHEME_STX_NULLP(SCHEME_STX_CDR(names)))
boundname = SCHEME_STX_CAR(names); boundname = SCHEME_STX_CAR(names);
else else
boundname = scheme_false; boundname = scheme_false;
SCHEME_EXPAND_OBSERVE_PREPARE_ENV(observer);
scheme_prepare_exp_env(env->genv); scheme_prepare_exp_env(env->genv);
scheme_prepare_compile_env(env->genv->exp_env); scheme_prepare_compile_env(env->genv->exp_env);
eenv = scheme_new_comp_env(env->genv->exp_env, env->insp, 0); eenv = scheme_new_comp_env(env->genv->exp_env, env->insp, 0);
@ -6935,7 +6943,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
erec1.comp = 0; erec1.comp = 0;
erec1.depth = -1; erec1.depth = -1;
erec1.value_name = boundname; erec1.value_name = boundname;
erec1.observer = rec[drec].observer; erec1.observer = observer;
erec1.pre_unwrapped = 0; erec1.pre_unwrapped = 0;
erec1.env_already = 0; erec1.env_already = 0;
erec1.comp_flags = rec[drec].comp_flags; erec1.comp_flags = rec[drec].comp_flags;
@ -6945,7 +6953,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
adt = scheme_hash_tree_set(bxs->all_defs, scheme_make_integer(phase), all_rt_defs); adt = scheme_hash_tree_set(bxs->all_defs, scheme_make_integer(phase), all_rt_defs);
bxs->all_defs = adt; bxs->all_defs = adt;
if (erec) { if (erec) {
SCHEME_EXPAND_OBSERVE_PHASE_UP(observer); /* FIXME [Ryan?]? */ SCHEME_EXPAND_OBSERVE_PHASE_UP(observer);
/* We expand & compile the for-syntax code in one pass. */ /* We expand & compile the for-syntax code in one pass. */
} }
m = do_module_begin_at_phase(code, eenv, m = do_module_begin_at_phase(code, eenv,
@ -7261,6 +7269,8 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
/* Pass 3 */ /* Pass 3 */
/* if at phase 0, expand provides for all phases */ /* if at phase 0, expand provides for all phases */
SCHEME_EXPAND_OBSERVE_NEXT_GROUP(observer);
if (phase == 0) { if (phase == 0) {
Scheme_Object *expanded_provides; Scheme_Object *expanded_provides;

10
src/racket/src/schexpobs.h
View File

@ -114,6 +114,9 @@ extern Scheme_Object *scheme_get_expand_observe();
#define SCHEME_EXPAND_OBSERVE_PRIM_STRATIFIED(observer) \ #define SCHEME_EXPAND_OBSERVE_PRIM_STRATIFIED(observer) \
_SCHEME_EXPOBS(observer,155,scheme_false) _SCHEME_EXPOBS(observer,155,scheme_false)
#define SCHEME_EXPAND_OBSERVE_PRIM_BEGIN_FOR_SYNTAX(observer) \
_SCHEME_EXPOBS(observer,156,scheme_false)
#define SCHEME_EXPAND_OBSERVE_VARIABLE(observer,e1,e2) \ #define SCHEME_EXPAND_OBSERVE_VARIABLE(observer,e1,e2) \
_SCHEME_EXPOBS(observer,125,scheme_make_pair(e1, e2)) _SCHEME_EXPOBS(observer,125,scheme_make_pair(e1, e2))
@ -126,7 +129,7 @@ extern Scheme_Object *scheme_get_expand_observe();
_SCHEME_EXPOBS(observer,128,stx) _SCHEME_EXPOBS(observer,128,stx)
#define SCHEME_EXPAND_OBSERVE_LETLIFT_LOOP(observer,stx) \ #define SCHEME_EXPAND_OBSERVE_LETLIFT_LOOP(observer,stx) \
_SCHEME_EXPOBS(observer,136,stx) _SCHEME_EXPOBS(observer,136,stx)
#define SCHEME_EXPAND_OBSERVE_MODULE_LIFT_LOOP(observe,stxs) \ #define SCHEME_EXPAND_OBSERVE_MODULE_LIFT_LOOP(observer,stxs) \
_SCHEME_EXPOBS(observer,137,stxs) _SCHEME_EXPOBS(observer,137,stxs)
#define SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer,stx) \ #define SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer,stx) \
_SCHEME_EXPOBS(observer,135,stx) _SCHEME_EXPOBS(observer,135,stx)
@ -185,6 +188,9 @@ extern Scheme_Object *scheme_get_expand_observe();
#define SCHEME_EXPAND_OBSERVE_LOCAL_VALUE_RESULT(obs,bound) \ #define SCHEME_EXPAND_OBSERVE_LOCAL_VALUE_RESULT(obs,bound) \
_SCHEME_EXPOBS(obs,154,bound) _SCHEME_EXPOBS(obs,154,bound)
/* next: 156 */ #define SCHEME_EXPAND_OBSERVE_PREPARE_ENV(obs) \
_SCHEME_EXPOBS(obs,157,scheme_false)
/* next: 158 */
#endif #endif