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

macro stepper: small reorg.

Browse Source 
svn: r12693
This commit is contained in:
Ryan Culpepper 2008-12-03 22:24:13 +00:00
parent 97fafb6ce4
commit ac293ce4c7
1 changed files with 36 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
collects/macro-debugger/tool.ss
View File

@ -201,36 +201,44 @@
(define/private (make-stepper filename)
(new drscheme-macro-stepper-director% (filename filename)))
(define/private (inner-eval original-eval-handler e-expr)
(original-eval-handler e-expr))
(define/private (make-handlers original-eval-handler
original-module-name-resolver)
(let* ([filename (send (send (get-top-level-window)
get-definitions-text)
get-filename/untitled-name)]
[director (make-stepper filename)]
[debugging? debugging?])
(set! current-stepper-director director)
(values
(lambda (expr)
(if (and debugging? (syntax? expr))
(let-values ([(e-expr events derivp) (trace* expr expand)])
(show-deriv director events)
(if (syntax? e-expr)
(parameterize ((current-eval original-eval-handler))
(original-eval-handler e-expr))
(raise e-expr)))
(original-eval-handler expr)))
(lambda args
(let ([eo (current-expand-observe)]
[saved-debugging? debugging?])
(dynamic-wind
(lambda ()
(set! debugging? #f)
(when eo (current-expand-observe void)))
(lambda ()
(apply original-module-name-resolver args))
(lambda ()
(set! debugging? saved-debugging?)
(when eo (current-expand-observe eo)))))))))
(define filename (send (send (get-top-level-window) get-definitions-text)
get-filename/untitled-name))
(define director (make-stepper filename))
(define local-debugging? debugging?)
(define (call-without-debugging thunk)
(let ([eo (current-expand-observe)]
[saved-debugging? local-debugging?])
(dynamic-wind
(lambda ()
(set! local-debugging? #f)
(when eo (current-expand-observe void)))
thunk
(lambda ()
(set! local-debugging? saved-debugging?)
(when eo (current-expand-observe eo))))))
(define (the-eval expr)
(if (and local-debugging? (syntax? expr))
(let-values ([(e-expr events derivp) (trace* expr expand)])
(show-deriv director events)
(if (syntax? e-expr)
(inner-eval e-expr)
(raise e-expr)))
(original-eval-handler expr)))
(define (inner-eval e-expr)
(if #f ;; fixme: turn into parameter/preference???
(call-without-debugging (lambda () (original-eval-handler e-expr)))
(original-eval-handler e-expr)))
(define (the-module-resolver . args)
(call-without-debugging
(lambda () (apply original-module-name-resolver args))))
(set! current-stepper-director director)
(values the-eval
the-module-resolver))
(define/private (show-deriv director events)
(parameterize ([current-eventspace drscheme-eventspace])