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

fixed a bug intraces/ps

Browse Source 
svn: r13062
This commit is contained in:
Robby Findler 2009-01-10 23:49:03 +00:00
parent 538a1e695e
commit 3ceb88b8a7
1 changed files with 26 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
collects/redex/private/traces.ss
View File

@ -130,21 +130,21 @@
#:scheme-colors? [scheme-colors? #t] #:scheme-colors? [scheme-colors? #t]
#:colors [colors '()] #:colors [colors '()]
#:layout [layout void]) #:layout [layout void])
(let ([graph-pb (let-values ([(graph-pb frame)
(traces reductions pre-exprs (traces reductions pre-exprs
#:no-show-frame? #t #:no-show-frame? #t
#:multiple? multiple? #:multiple? multiple?
#:pred pred #:pred pred
#:pp pp #:pp pp
#:scheme-colors? scheme-colors? #:scheme-colors? scheme-colors?
#:colors colors #:colors colors
#:layout layout)] #:layout layout)])
[ps-setup (make-object ps-setup%)]) (let ([ps-setup (make-object ps-setup%)])
(send ps-setup copy-from (current-ps-setup)) (send ps-setup copy-from (current-ps-setup))
(send ps-setup set-file filename) (send ps-setup set-file filename)
(send ps-setup set-mode 'file) (send ps-setup set-mode 'file)
(parameterize ([current-ps-setup ps-setup]) (parameterize ([current-ps-setup ps-setup])
(send graph-pb print #f #f 'postscript #f #f #t)))) (send graph-pb print #f #f 'postscript #f #f #t)))))
(define (traces reductions pre-exprs (define (traces reductions pre-exprs
#:multiple? [multiple? #f] #:multiple? [multiple? #f]
@ -471,10 +471,17 @@
(insert-into init-rightmost-x 0 graph-pb frontier) (insert-into init-rightmost-x 0 graph-pb frontier)
(layout (map (lambda (y) (send y get-term-node)) frontier)) (layout (map (lambda (y) (send y get-term-node)) frontier))
(set-font-size (initial-font-size)) (set-font-size (initial-font-size))
(reduce-button-callback) (cond
(if no-show-frame? [no-show-frame?
graph-pb (let ([s (make-semaphore)])
(send f show #t))) (thread (λ ()
(do-some-reductions)
(semaphore-post s)))
(yield s))
(values graph-pb f)]
[else
(reduce-button-callback)
(send f show #t)]))
(define red-sem-frame% (define red-sem-frame%
(class (frame:standard-menus-mixin (frame:basic-mixin frame%)) (class (frame:standard-menus-mixin (frame:basic-mixin frame%))