fix a bug in the kill-safe abstraction that is designed to protect

the state that online check syntax uses (indirectly via scribble)
to lookup documentation.

since the kill-safe abstraction moved some computation over to
another thread, the values of various parameters (current-directory
in this case) were not preserved. So when scribble then ended up
resolving a module path with the wrong current directory, this
bad value got cached. Then later, when check syntax tries to figure
out what file to open to jump to it, it got the cached bogus value
(even though current-directory was right when check syntax asked
for the filename).

closes PR 12538
This commit is contained in:
Robby Findler 2011-12-15 20:30:43 -06:00
parent a2bbcf8b00
commit a122ea725d

View File

@ -22,19 +22,20 @@
(thread (thread
(λ () (λ ()
(let loop () (let loop ()
(define-values (binding-info resp-chan nack-evt) (apply values (channel-get req-chan))) (define-values (binding-info cd resp-chan nack-evt) (apply values (channel-get req-chan)))
(define xref (force delayed-xref))
(define resp (define resp
(and xref (parameterize ([current-directory cd])
(let ([definition-tag (xref-binding->definition-tag xref binding-info #f)]) (define xref (force delayed-xref))
(and definition-tag (and xref
(let-values ([(path tag) (xref-tag->path+anchor xref definition-tag)]) (let ([definition-tag (xref-binding->definition-tag xref binding-info #f)])
(and path (and definition-tag
(let ([index-entry (xref-tag->index-entry xref definition-tag)]) (let-values ([(path tag) (xref-tag->path+anchor xref definition-tag)])
(and index-entry (and path
(list (entry-desc index-entry) (let ([index-entry (xref-tag->index-entry xref definition-tag)])
path (and index-entry
tag))))))))) (list (entry-desc index-entry)
path
tag))))))))))
(thread (thread
(λ () (λ ()
(sync (channel-put-evt resp-chan resp) (sync (channel-put-evt resp-chan resp)
@ -50,5 +51,5 @@
(nack-guard-evt (nack-guard-evt
(λ (nack-evt) (λ (nack-evt)
(define resp-chan (make-channel)) (define resp-chan (make-channel))
(channel-put req-chan (list binding-info resp-chan nack-evt)) (channel-put req-chan (list binding-info (current-directory) resp-chan nack-evt))
resp-chan))))) resp-chan)))))