commit f392ff8d8f255b7083ae60c59673350a02407a4e
parent 3ce3c33b954e707ecf1cdf27df73696cadf6c9b9
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Thu, 25 Feb 2010 02:05:26 +0000
macro-debugger:
fixed bug re (maybe?) lazy phase 1 initialization
fixed popup-menu bug in syntax browser
cleaned up signal mapping
svn: r18331
original commit: ea19a1bda345fee2d998e7b3f5120659ce6f4f50
Diffstat:
7 files changed, 133 insertions(+), 129 deletions(-)
diff --git a/collects/macro-debugger/model/deriv-c.ss b/collects/macro-debugger/model/deriv-c.ss
@@ -169,6 +169,6 @@
;; ECTE represents expand/compile-time-evals
-;; (make-ecte stx ?stx Deriv Deriv)
+;; (make-ecte stx ?stx (listof LocalAction) Deriv Deriv)
-(define-struct (ecte deriv) (first second) #:transparent)
+(define-struct (ecte deriv) (locals first second) #:transparent)
diff --git a/collects/macro-debugger/model/deriv-parser.ss b/collects/macro-debugger/model/deriv-parser.ss
@@ -68,18 +68,19 @@
(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)
+ ;; The 'Eval' is there for---I believe---lazy phase 1 initialization.
+ [(visit start (? Eval) (? CheckImmediateMacro/Lifts) top-non-begin start (? EE) return)
+ (make ecte $1 $8 $3 $4 $7)]
+ [(visit start Eval 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)))
+ (unless (list? $6)
+ (error "NextExpandCTEs returned non-list ~s" $6))
+ (make ecte $1 $7 $3 $4
+ (make p:begin $5 $7 (list (stx-car $5)) #f
+ (make lderiv (cdr (stx->list $5))
+ (and $7 (cdr (stx->list $7)))
#f
- $5))))])
+ $6))))])
(CheckImmediateMacro/Lifts
[((? CheckImmediateMacro))
diff --git a/collects/macro-debugger/model/deriv-tokens.ss b/collects/macro-debugger/model/deriv-tokens.ss
@@ -86,102 +86,104 @@
;; ** Signals to tokens
(define signal-mapping
- `((EOF . EOF)
- (error . ,token-syntax-error)
- (0 . ,token-visit)
- (1 . ,token-resolve)
- (2 . ,token-return)
- (3 . ,token-next)
- (4 . ,token-enter-list)
- (5 . ,token-exit-list)
- (6 . ,token-enter-prim)
- (7 . ,token-exit-prim)
- (8 . ,token-enter-macro)
- (9 . ,token-exit-macro)
- (10 . ,token-enter-block)
- (11 . ,token-splice)
- (12 . ,token-block->list)
- (13 . ,token-next-group)
- (14 . ,token-block->letrec)
- (16 . ,token-renames-let)
- (17 . ,token-renames-lambda)
- (18 . ,token-renames-case-lambda)
- (19 . ,token-renames-letrec-syntaxes)
- (20 . phase-up)
- (21 . ,token-macro-pre-transform)
- (22 . ,token-macro-post-transform)
- (23 . ,token-module-body)
- (24 . ,token-renames-block)
-
- (100 . prim-stop)
- (101 . prim-module)
- (102 . prim-#%module-begin)
- (103 . prim-define-syntaxes)
- (104 . prim-define-values)
- (105 . prim-if)
- (106 . prim-wcm)
- (107 . prim-begin)
- (108 . prim-begin0)
- (109 . prim-#%app)
- (110 . prim-lambda)
- (111 . prim-case-lambda)
- (112 . prim-let-values)
- (113 . prim-letrec-values)
- (114 . prim-letrec-syntaxes+values)
- (115 . prim-#%datum)
- (116 . prim-#%top)
- (117 . prim-quote)
- (118 . prim-quote-syntax)
- (119 . prim-require)
- (120 . prim-require-for-syntax)
- (121 . prim-require-for-template)
- (122 . prim-provide)
- (123 . prim-set!)
- (124 . prim-let*-values)
- (125 . ,token-variable)
- (126 . ,token-enter-check)
- (127 . ,token-exit-check)
- (128 . ,token-lift-loop)
- (129 . ,token-lift)
- (130 . ,token-enter-local)
- (131 . ,token-exit-local)
- (132 . ,token-local-pre)
- (133 . ,token-local-post)
- (134 . ,token-lift-statement)
- (135 . ,token-module-lift-end-loop)
- (136 . ,token-lift/let-loop)
- (137 . ,token-module-lift-loop)
- (138 . prim-expression)
- (141 . ,token-start)
- (142 . ,token-tag)
- (143 . ,token-local-bind)
- (144 . ,token-enter-bind)
- (145 . ,token-exit-bind)
- (146 . ,token-opaque)
- (147 . ,token-rename-list)
- (148 . ,token-rename-one)
- (149 . prim-varref)
- (150 . ,token-lift-require)
- (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)
+ ;; (number/#f symbol [token-constructor])
+ `(;; Emitted from Scheme
+ (#f EOF)
+ (#f error ,token-syntax-error)
+ (#f start ,token-start)
+ (#f top-begin ,token-top-begin)
+ (#f top-non-begin ,token-top-non-begin)
+
+ ;; Standard signals
+ (0 visit ,token-visit)
+ (1 resolve ,token-resolve)
+ (2 return ,token-return)
+ (3 next ,token-next)
+ (4 enter-list ,token-enter-list)
+ (5 exit-list ,token-exit-list)
+ (6 enter-prim ,token-enter-prim)
+ (7 exit-prim ,token-exit-prim)
+ (8 enter-macro ,token-enter-macro)
+ (9 exit-macro ,token-exit-macro)
+ (10 enter-block ,token-enter-block)
+ (11 splice ,token-splice)
+ (12 block->list ,token-block->list)
+ (13 next-group ,token-next-group)
+ (14 block->letrec ,token-block->letrec)
+ (16 renames-let ,token-renames-let)
+ (17 renames-lambda ,token-renames-lambda)
+ (18 renames-case-lambda ,token-renames-case-lambda)
+ (19 renames-letrec-syntaxes ,token-renames-letrec-syntaxes)
+ (20 phase-up)
+ (21 macro-pre-transform ,token-macro-pre-transform)
+ (22 macro-post-transform ,token-macro-post-transform)
+ (23 module-body ,token-module-body)
+ (24 renames-block ,token-renames-block)
+
+ (100 prim-stop)
+ (101 prim-module)
+ (102 prim-#%module-begin)
+ (103 prim-define-syntaxes)
+ (104 prim-define-values)
+ (105 prim-if)
+ (106 prim-wcm)
+ (107 prim-begin)
+ (108 prim-begin0)
+ (109 prim-#%app)
+ (110 prim-lambda)
+ (111 prim-case-lambda)
+ (112 prim-let-values)
+ (113 prim-letrec-values)
+ (114 prim-letrec-syntaxes+values)
+ (115 prim-#%datum)
+ (116 prim-#%top)
+ (117 prim-quote)
+ (118 prim-quote-syntax)
+ (119 prim-require)
+ (120 prim-require-for-syntax)
+ (121 prim-require-for-template)
+ (122 prim-provide)
+ (123 prim-set!)
+ (124 prim-let*-values)
+ (125 variable ,token-variable)
+ (126 enter-check ,token-enter-check)
+ (127 exit-check ,token-exit-check)
+ (128 lift-loop ,token-lift-loop)
+ (129 lift ,token-lift)
+ (130 enter-local ,token-enter-local)
+ (131 exit-local ,token-exit-local)
+ (132 local-pre ,token-local-pre)
+ (133 local-post ,token-local-post)
+ (134 lift-statement ,token-lift-statement)
+ (135 lift-end-loop ,token-module-lift-end-loop)
+ (136 lift/let-loop ,token-lift/let-loop)
+ (137 module-lift-loop ,token-module-lift-loop)
+ (138 prim-expression)
+ (141 start ,token-start)
+ (142 tag ,token-tag)
+ (143 local-bind ,token-local-bind)
+ (144 enter-bind ,token-enter-bind)
+ (145 exit-bind ,token-exit-bind)
+ (146 opaque ,token-opaque)
+ (147 rename-list ,token-rename-list)
+ (148 rename-one ,token-rename-one)
+ (149 prim-varref)
+ (150 lift-require ,token-lift-require)
+ (151 lift-provide ,token-lift-provide)
))
-(define (tokenize sig-n val pos)
- (let ([p (assv sig-n signal-mapping)])
- (if (pair? p)
- (make-position-token
- (cond [(procedure? (cdr p)) ((cdr p) val)]
- [(symbol? (cdr p)) (cdr p)])
- pos
- pos)
- (error 'tokenize "bad signal: ~s" sig-n))))
-
-(define (signal->symbol sig-n)
- (cdr (assv sig-n signal-mapping)))
+(define (signal->symbol sig)
+ (if (symbol? sig)
+ sig
+ (cadr (assv sig signal-mapping))))
+
+(define token-mapping (map cdr signal-mapping))
+
+(define (tokenize sig val pos)
+ (let ([p (assv sig token-mapping)])
+ (cond [(not p)
+ (error 'tokenize "bad signal: ~s" sig)]
+ [(null? (cdr p))
+ (make-position-token sig pos pos)]
+ [else
+ (make-position-token ((cadr p) val) pos pos)])))
diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss
@@ -280,9 +280,10 @@
;; expand/compile-time-evals
- [(Wrap ecte (e1 e2 first second))
+ [(Wrap ecte (e1 e2 locals first second))
(R [#:pattern ?form]
[#:pass1]
+ [LocalActions ?form locals]
[Expr ?form first]
[#:pass2]
[Expr ?form second])]
diff --git a/collects/macro-debugger/model/trace.ss b/collects/macro-debugger/model/trace.ss
@@ -43,7 +43,7 @@
;; events->token-generator : (list-of event) -> (-> token)
(define (events->token-generator events)
- (let ([pos 0])
+ (let ([pos 1])
(lambda ()
(define sig+val (car events))
(set! events (cdr events))
@@ -64,7 +64,7 @@
(define events null)
(define counter 0)
(define (add! x y)
- (set! events (cons (cons x y) events)))
+ (set! events (cons (cons (signal->symbol x) y) events)))
(define add!/check
(let ([limit (trace-macro-limit)]
[handler (trace-limit-handler)])
diff --git a/collects/macro-debugger/syntax-browser/keymap.ss b/collects/macro-debugger/syntax-browser/keymap.ss
@@ -91,6 +91,17 @@
(lambda (i e)
(call-function "copy-syntax-as-text" i e))))
(new separator-menu-item% (parent menu))
+ (new menu-item%
+ (label "Clear selection")
+ (parent menu)
+ (demand-callback
+ (lambda (i)
+ (send i enable (and (selected-syntax) #t))))
+ (callback
+ (lambda (i e)
+ (call-function "clear-syntax-selection" i e))))
+ (menu-option/notify-box menu "View syntax properties"
+ (get-field props-shown? config))
(let ([pretty-menu
(new menu%
(label "Change layout")
@@ -108,19 +119,8 @@
(demand-callback
(lambda (i)
(let ([stx (selected-syntax)])
- (send i set-label
- (format "Format ~s ~a" (syntax-e stx) (cadr sym+desc))))))
+ (when stx
+ (send i set-label
+ (format "Format ~s ~a" (syntax-e stx) (cadr sym+desc)))))))
(callback
- (pretty-print-as (car sym+desc))))))
- (new menu-item%
- (label "Clear selection")
- (parent menu)
- (demand-callback
- (lambda (i)
- (send i enable (and (selected-syntax) #t))))
- (callback
- (lambda (i e)
- (call-function "clear-syntax-selection" i e))))
- (menu-option/notify-box menu "View syntax properties"
- (get-field props-shown? config)))))
-
+ (pretty-print-as (car sym+desc)))))))))
diff --git a/collects/macro-debugger/view/stepper.ss b/collects/macro-debugger/view/stepper.ss
@@ -433,11 +433,11 @@
(and first
(let ([e1 (wderiv-e1 first)])
(make-lift-deriv e1 e2 first lifted-stx second))))]
- [(Wrap ecte (e1 e2 first second))
+ [(Wrap ecte (e1 e2 locals first second))
(let ([first (adjust-deriv/lift first)])
(and first
(let ([e1 (wderiv-e1 first)])
- (make ecte e1 e2 first second))))]
+ (make ecte e1 e2 locals first second))))]
[else (adjust-deriv/top deriv)]))
;; adjust-deriv/top : Derivation -> Derivation
