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

Macro stepper: eliminated (unneeded) synchronization from tracing

Browse Source 
svn: r5544

original commit: c4c5d6cd13715cbef58ca03cb3bacf4af9e53526
This commit is contained in:
Ryan Culpepper 2007-02-02 19:56:03 +00:00
parent d4b7882999
commit c5ab275cee
1 changed files with 18 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
collects/macro-debugger/model/trace.ss
View File

@ -38,27 +38,15 @@
;; expand+tracer : syntax/sexpr (syntax -> A) -> (values A/exn (-> event)) ;; expand+tracer : syntax/sexpr (syntax -> A) -> (values A/exn (-> event))
(define (expand+tracer sexpr expander) (define (expand+tracer sexpr expander)
(let* ([s (make-semaphore 1)] (let* ([events null]
[head (cons #f #f)]
[tail head]
[pos 0]) [pos 0])
(define (add! x) (define (add! x)
(semaphore-wait s) (set! events (cons x events)))
(set-car! tail x)
(set-cdr! tail (cons #f #f))
(set! tail (cdr tail))
(semaphore-post s))
(define get
(let ([head head])
(lambda ()
(semaphore-wait s)
(let ([result (car head)])
(set! head (cdr head))
(semaphore-post s)
result))))
(parameterize ((current-expand-observe (parameterize ((current-expand-observe
(lambda (sig val) (let ([c 0])
(add! (cons sig val))))) (lambda (sig val)
(set! c (add1 c))
(add! (cons sig val))))))
(let ([result (let ([result
(with-handlers ([(lambda (exn) #t) (with-handlers ([(lambda (exn) #t)
(lambda (exn) (lambda (exn)
@ -67,14 +55,17 @@
(expander sexpr))]) (expander sexpr))])
(add! (cons 'EOF pos)) (add! (cons 'EOF pos))
(values result (values result
(lambda () (let ([events (reverse events)])
(let* ([sig+val (get)] (lambda ()
[sig (car sig+val)] (define sig+val (car events))
[val (cdr sig+val)] (set! events (cdr events))
[t (tokenize sig val pos)]) (let* ([sig (car sig+val)]
(when (trace-verbose?) [val (cdr sig+val)]
(printf "~s: ~s~n" pos (token-name (position-token-token t)))) [t (tokenize sig val pos)])
(set! pos (add1 pos)) (when (trace-verbose?)
t))))))) (printf "~s: ~s~n" pos
(token-name (position-token-token t))))
(set! pos (add1 pos))
t))))))))
) )