Macro stepper: internal debugging improvements
svn: r5511 original commit: d76d947d9396347d8c0029b3235950a772986511
This commit is contained in:
parent
6641e1fe7a
commit
dd90b92c3d
|
@ -83,7 +83,6 @@
|
|||
(12 . ,token-block->list)
|
||||
(13 . ,token-next-group)
|
||||
(14 . ,token-block->letrec)
|
||||
#;(15 . renamer)
|
||||
(16 . ,token-renames-let)
|
||||
(17 . ,token-renames-lambda)
|
||||
(18 . ,token-renames-case-lambda)
|
||||
|
@ -144,4 +143,7 @@
|
|||
pos)
|
||||
(error 'tokenize "bad signal: ~s" sig-n))))
|
||||
|
||||
(define (signal->symbol sig-n)
|
||||
(cdr (assv sig-n signal-mapping)))
|
||||
|
||||
)
|
||||
|
|
|
@ -11,27 +11,27 @@
|
|||
(dynamic-require '#%expobs 'current-expand-observe))
|
||||
|
||||
(define (go-trace sexpr)
|
||||
(define browser
|
||||
(parameterize (#;(identifier=-choices
|
||||
(list (cons "related by table"
|
||||
(lambda (a b) (related-by-table table a b))))))
|
||||
(make-syntax-browser)))
|
||||
(define table #f)
|
||||
(define events null)
|
||||
(define pos 0)
|
||||
(define browser (make-syntax-browser))
|
||||
(define (show sig+val)
|
||||
(define sig (car sig+val))
|
||||
(define val (cdr sig+val))
|
||||
(define t (tokenize sig val pos))
|
||||
(send browser add-text
|
||||
(format "Signal: ~s: ~s~n"
|
||||
pos
|
||||
(token-name (position-token-token t))))
|
||||
(when val
|
||||
(send browser add-syntax
|
||||
(datum->syntax-object #f val)))
|
||||
(set! pos (add1 pos)))
|
||||
(parameterize ((current-expand-observe
|
||||
(lambda (sig val)
|
||||
(define t (tokenize sig val pos))
|
||||
(send browser add-text
|
||||
(format "Signal: ~s: ~s~n"
|
||||
pos
|
||||
(token-name (position-token-token t))))
|
||||
(send browser add-syntax
|
||||
(datum->syntax-object #f val))
|
||||
(set! pos (add1 pos)))))
|
||||
(expand sexpr)))
|
||||
|
||||
(define (related-by-table table a b)
|
||||
(or (eq? a b)
|
||||
#;(and table '...)))
|
||||
(set! events (cons (cons sig val) events))
|
||||
#;(show (cons sig val)))))
|
||||
(expand sexpr)
|
||||
(for-each show (reverse events))))
|
||||
|
||||
)
|
Loading…
Reference in New Issue
Block a user