diff --git a/collects/macro-debugger/model/deriv-c.ss b/collects/macro-debugger/model/deriv-c.ss index a81ad12dec..e8a12d31e1 100644 --- a/collects/macro-debugger/model/deriv-c.ss +++ b/collects/macro-debugger/model/deriv-c.ss @@ -20,13 +20,15 @@ (define-struct transformation (e1 e2 resolves me1 me2 locals seq) #f) ;; A LocalAction is one of - ;; - (make-local-expansion Syntax Syntax Syntax Syntax Derivation) + ;; - (make-local-expansion Syntax Syntax Syntax Syntax boolean Derivation) + ;; - (make-local-expansion/expr Syntax Syntax Syntax Syntax boolean Derivation) ;; - (make-local-lift Syntax Identifier) - (define-struct local-expansion (e1 e2 me1 me2 deriv) #f) + (define-struct local-expansion (e1 e2 me1 me2 for-stx? deriv) #f) + (define-struct local-expansion/expr (e1 e2 me1 me2 for-stx? opaque deriv) #f) (define-struct local-lift (expr id) #f) (define-struct local-lift-end (decl) #f) (define-struct local-bind (deriv) #f) - + ;; A PRule is one of ... (define-struct (prule deriv) (resolves) #f) diff --git a/collects/macro-debugger/model/deriv-parser.ss b/collects/macro-debugger/model/deriv-parser.ss index 8549c95976..f374d359c2 100644 --- a/collects/macro-debugger/model/deriv-parser.ss +++ b/collects/macro-debugger/model/deriv-parser.ss @@ -45,7 +45,7 @@ enter-block block->list block->letrec splice enter-list exit-list enter-check exit-check - local-post exit-local + local-post exit-local exit-local/expr phase-up module-body renames-lambda renames-case-lambda @@ -155,7 +155,13 @@ (LocalAction (#:no-wrap) [(enter-local local-pre (? EE) local-post exit-local) - (make-local-expansion $1 $5 $2 $4 $3)] + (make-local-expansion $1 $5 $2 $4 #f $3)] + [(enter-local phase-up local-pre (? EE) local-post exit-local) + (make-local-expansion $1 $6 $3 $5 #t $4)] + [(enter-local/expr local-pre (? EE) local-post exit-local/expr) + (make-local-expansion/expr $1 (car $5) $2 $4 #f (cdr $5) $3)] + [(enter-local/expr local-pre phase-up (? EE) local-post exit-local/expr) + (make-local-expansion/expr $1 (car $6) $3 $5 #t (cdr $6) $4)] [(lift) (make-local-lift (cdr $1) (car $1))] [(lift-statement) diff --git a/collects/macro-debugger/model/deriv-tokens.ss b/collects/macro-debugger/model/deriv-tokens.ss index c63cbd4667..a1a6ca95c4 100644 --- a/collects/macro-debugger/model/deriv-tokens.ss +++ b/collects/macro-debugger/model/deriv-tokens.ss @@ -3,7 +3,7 @@ (require (lib "lex.ss" "parser-tools") "deriv.ss") (provide (all-defined)) - + (define-tokens basic-tokens (visit ; syntax resolve ; identifier @@ -39,6 +39,9 @@ local-pre ; syntax local-post ; syntax exit-local ; syntax + + enter-local/expr ; syntax + exit-local/expr ; (cons syntax expanded-expression) variable ; (cons identifier identifier) @@ -133,6 +136,8 @@ (136 . ,token-lift/let-loop) (137 . ,token-module-lift-loop) (138 . prim-expression) + (139 . ,token-enter-local/expr) + (140 . ,token-exit-local/expr) )) (define (tokenize sig-n val pos) diff --git a/collects/macro-debugger/model/deriv-util.ss b/collects/macro-debugger/model/deriv-util.ss index 5df7c859d5..aeb1630237 100644 --- a/collects/macro-debugger/model/deriv-util.ss +++ b/collects/macro-debugger/model/deriv-util.ss @@ -176,7 +176,9 @@ (join (loop first) (loop second))] [(AnyQ transformation (_ _ _ _ _ locals _)) (loops locals)] - [(struct local-expansion (_ _ _ _ deriv)) + [(struct local-expansion (_ _ _ _ _ deriv)) + (loop deriv)] + [(struct local-expansion/expr (_ _ _ _ _ _ deriv)) (loop deriv)] [(struct local-bind (deriv)) (loop deriv)] diff --git a/collects/macro-debugger/model/hide.ss b/collects/macro-debugger/model/hide.ss index 318893dbb0..52862382f9 100644 --- a/collects/macro-debugger/model/hide.ss +++ b/collects/macro-debugger/model/hide.ss @@ -419,9 +419,11 @@ ;; for-local-action : LocalAction -> LocalAction (define (for-local-action la) (match la - [(struct local-expansion (e1 e2 me1 me2 deriv)) + [(struct local-expansion (e1 e2 me1 me2 for-stx? deriv)) (let-values ([(deriv e2) (for-deriv deriv)]) - (make-local-expansion e1 e2 me1 me2 deriv))] + (make-local-expansion e1 e2 me1 me2 for-stx? deriv))] + [(struct local-expansion/expr (e1 e2 me1 me2 for-stx? opaque deriv)) + (error 'hide:for-local-action "not implemented for local-expand-expr")] [(struct local-lift (expr id)) (add-unhidden-lift (extract/remove-unvisited-lift id)) la] @@ -725,7 +727,9 @@ ;; for-local-action : LocalAction -> (list-of Subterm) (define (for-local-action local) (match local - [(struct local-expansion (e1 e2 me1 me2 deriv)) + [(struct local-expansion (e1 e2 me1 me2 for-stx? deriv)) + (raise (make-localactions))] + [(struct local-expansion/expr (e1 e2 me1 me2 for-stx? opaque deriv)) (raise (make-localactions))] [(struct local-lift (expr id)) ;; FIXME: seek in the lifted deriv, transplant subterm expansions *here* diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss index 75bcf7bf54..c3323bdf06 100644 --- a/collects/macro-debugger/model/reductions.ss +++ b/collects/macro-debugger/model/reductions.ss @@ -389,7 +389,11 @@ ;; reductions-local : LocalAction -> ReductionSequence (define (reductions-local local) (match/with-derivation local - [(struct local-expansion (e1 e2 me1 me2 deriv)) + [(struct local-expansion (e1 e2 me1 me2 for-stx? deriv)) + (reductions* deriv)] + [(struct local-expansion/expr (e1 e2 me1 me2 for-stx? opaque deriv)) + (fprintf (current-error-port) + "reductions: local-expand-expr not fully implemented") (reductions* deriv)] [(struct local-lift (expr id)) (list (walk expr id 'local-lift))]