commit 44672c7c5dfb3611778581eca8b421745bc30946
parent 2d29222912a5da59b951d539c6f2e481e09bc9bf
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Tue, 13 Jul 2010 10:53:04 -0600
macro-stepper: better internal debugging
original commit: cb62eeffb6cacf0a8488176804fe722544bb5e73
Diffstat:
2 files changed, 27 insertions(+), 23 deletions(-)
diff --git a/collects/macro-debugger/model/reductions-engine.rkt b/collects/macro-debugger/model/reductions-engine.rkt
@@ -150,7 +150,7 @@
(current-state-with v (with-syntax1 ([p f]) fs)))]
[type-var type])
(DEBUG
- (printf "visibility = ~s\n" (visibility))
+ (printf "visibility = ~s\n" (if (visibility) 'VISIBLE 'HIDDEN))
(printf "step: s1 = ~s\n" s)
(printf "step: s2 = ~s\n\n" s2))
(let ([ws2
@@ -324,7 +324,7 @@
(visibility-off (not previous-pass-hides?)
v
(lambda ()
- (print-viable-subterms v)
+ (when #f (print-viable-subterms v))
(R** f v p s ws clause ... => k))
#t))]
@@ -495,26 +495,29 @@
(define (seek-point stx vstx k)
(if (visibility)
(k vstx)
- (let ([paths (table-get (subterms-table) stx)])
- (cond [(null? paths)
- (DEBUG (printf "seek-point: failed on ~.s\n" (stx->datum stx)))
- (k vstx)]
- [(null? (cdr paths))
- (let ([path (car paths)])
- (DEBUG (printf "seek => hide: ~.s\n" (stx->datum stx)))
- (let ([ctx (lambda (x) (path-replace vstx path x))])
- (RScase (parameterize ((visibility #t)
- (subterms-table #f)
- (marking-table #f))
- ;; Found stx within vstx
- (with-context ctx (k stx)))
- (lambda (ws2 stx2 vstx2 s2)
- (let ([vstx2 (ctx vstx2)])
- (RSunit ws2 stx2 vstx2 s2)))
- (lambda (ws exn)
- (RSfail ws exn)))))]
- [else
- (raise (make nonlinearity stx paths))]))))
+ (begin
+ (DEBUG (printf "Seek point\n")
+ (print-viable-subterms stx))
+ (let ([paths (table-get (subterms-table) stx)])
+ (cond [(null? paths)
+ (DEBUG (printf "seek-point: failed on ~.s\n" (stx->datum stx)))
+ (k vstx)]
+ [(null? (cdr paths))
+ (let ([path (car paths)])
+ (DEBUG (printf "seek => hide: ~.s\n" (stx->datum stx)))
+ (let ([ctx (lambda (x) (path-replace vstx path x))])
+ (RScase (parameterize ((visibility #t)
+ (subterms-table #f)
+ (marking-table #f))
+ ;; Found stx within vstx
+ (with-context ctx (k stx)))
+ (lambda (ws2 stx2 vstx2 s2)
+ (let ([vstx2 (ctx vstx2)])
+ (RSunit ws2 stx2 vstx2 s2)))
+ (lambda (ws exn)
+ (RSfail ws exn)))))]
+ [else
+ (raise (make nonlinearity stx paths))])))))
(provide print-viable-subterms)
(define (print-viable-subterms stx)
diff --git a/collects/macro-debugger/model/steps.rkt b/collects/macro-debugger/model/steps.rkt
@@ -112,7 +112,8 @@
rename-case-lambda
rename-let-values
rename-letrec-values
- rename-lsv)))
+ rename-lsv
+ track-origin)))
(define (rewrite-step? x)
(and (step? x) (not (rename-step? x))))
