suzanne.soy/macro-debugger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

macro-stepper: better internal debugging

Browse Source 
original commit: cb62eeffb6cacf0a8488176804fe722544bb5e73
This commit is contained in:
Ryan Culpepper 2010-07-13 10:53:04 -06:00
parent 2d29222912
commit 44672c7c5d
2 changed files with 27 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
collects/macro-debugger/model/reductions-engine.rkt
View File

@ -150,7 +150,7 @@
(current-state-with v (with-syntax1 ([p f]) fs)))] (current-state-with v (with-syntax1 ([p f]) fs)))]
[type-var type]) [type-var type])
(DEBUG (DEBUG
(printf "visibility = ~s\n" (visibility)) (printf "visibility = ~s\n" (if (visibility) 'VISIBLE 'HIDDEN))
(printf "step: s1 = ~s\n" s) (printf "step: s1 = ~s\n" s)
(printf "step: s2 = ~s\n\n" s2)) (printf "step: s2 = ~s\n\n" s2))
(let ([ws2 (let ([ws2
@ -324,7 +324,7 @@
(visibility-off (not previous-pass-hides?) (visibility-off (not previous-pass-hides?)
v v
(lambda () (lambda ()
(print-viable-subterms v) (when #f (print-viable-subterms v))
(R** f v p s ws clause ... => k)) (R** f v p s ws clause ... => k))
#t))] #t))]
@ -495,26 +495,29 @@
(define (seek-point stx vstx k) (define (seek-point stx vstx k)
(if (visibility) (if (visibility)
(k vstx) (k vstx)
(let ([paths (table-get (subterms-table) stx)]) (begin
(cond [(null? paths) (DEBUG (printf "Seek point\n")
(DEBUG (printf "seek-point: failed on ~.s\n" (stx->datum stx))) (print-viable-subterms stx))
(k vstx)] (let ([paths (table-get (subterms-table) stx)])
[(null? (cdr paths)) (cond [(null? paths)
(let ([path (car paths)]) (DEBUG (printf "seek-point: failed on ~.s\n" (stx->datum stx)))
(DEBUG (printf "seek => hide: ~.s\n" (stx->datum stx))) (k vstx)]
(let ([ctx (lambda (x) (path-replace vstx path x))]) [(null? (cdr paths))
(RScase (parameterize ((visibility #t) (let ([path (car paths)])
(subterms-table #f) (DEBUG (printf "seek => hide: ~.s\n" (stx->datum stx)))
(marking-table #f)) (let ([ctx (lambda (x) (path-replace vstx path x))])
;; Found stx within vstx (RScase (parameterize ((visibility #t)
(with-context ctx (k stx))) (subterms-table #f)
(lambda (ws2 stx2 vstx2 s2) (marking-table #f))
(let ([vstx2 (ctx vstx2)]) ;; Found stx within vstx
(RSunit ws2 stx2 vstx2 s2))) (with-context ctx (k stx)))
(lambda (ws exn) (lambda (ws2 stx2 vstx2 s2)
(RSfail ws exn)))))] (let ([vstx2 (ctx vstx2)])
[else (RSunit ws2 stx2 vstx2 s2)))
(raise (make nonlinearity stx paths))])))) (lambda (ws exn)
(RSfail ws exn)))))]
[else
(raise (make nonlinearity stx paths))])))))
(provide print-viable-subterms) (provide print-viable-subterms)
(define (print-viable-subterms stx) (define (print-viable-subterms stx)

3
collects/macro-debugger/model/steps.rkt
View File

@ -112,7 +112,8 @@
rename-case-lambda rename-case-lambda
rename-let-values rename-let-values
rename-letrec-values rename-letrec-values
rename-lsv))) rename-lsv
track-origin)))
(define (rewrite-step? x) (define (rewrite-step? x)
(and (step? x) (not (rename-step? x)))) (and (step? x) (not (rename-step? x))))