check syntax now (silently) copes with an exception raised by the documentation xref loading

svn: r8439
This commit is contained in:
Robby Findler 2008-01-28 02:11:31 +00:00
parent d49f16da7f
commit eda72235bd

View File

@ -95,13 +95,23 @@ If the namespace does not, they are colored the unbound color.
(define xref 'not-yet-loaded-xref)
(define (get-xref)
(cond
[(equal? xref 'failed-to-load) #f]
[else
(when (symbol? xref)
(error 'get-xref "xref has not yet been loaded"))
xref)
xref]))
(define (force-xref th)
(when (symbol? xref)
(cond
[(equal? xref 'failed-to-load)
(void)]
[(symbol? xref)
(th)
(set! xref (load-collections-xref))))
(with-handlers ((exn? (λ (exn) (set! xref 'failed-to-load))))
(set! xref (load-collections-xref)))]
[else
(void)]))
;;; ;;; ;;; ;;;;;
@ -2382,11 +2392,13 @@ If the namespace does not, they are colored the unbound color.
(syntax-span stx))
(let* ([start (- (syntax-position stx) 1)]
[fin (+ start (syntax-span stx))]
[definition-tag (xref-binding->definition-tag (get-xref) binding-info #f)])
[xref (get-xref)])
(when xref
(let ([definition-tag (xref-binding->definition-tag xref binding-info #f)])
(when definition-tag
(let-values ([(path tag) (xref-tag->path+anchor (get-xref) definition-tag)])
(let-values ([(path tag) (xref-tag->path+anchor xref definition-tag)])
(when path
(let ([index-entry (xref-tag->index-entry (get-xref) definition-tag)])
(let ([index-entry (xref-tag->index-entry xref definition-tag)])
(when index-entry
(send defs-text syncheck:add-background-color defs-text "navajowhite" start fin (syntax-e stx))
(send defs-text syncheck:add-menu
@ -2404,7 +2416,7 @@ If the namespace does not, they are colored the unbound color.
(path->string path)
(if tag
(string-append "#" (uri-encode tag))
""))))))))))))))))))))
""))))))))))))))))))))))