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

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

Browse Source 
svn: r8439
This commit is contained in:
Robby Findler 2008-01-28 02:11:31 +00:00
parent d49f16da7f
commit eda72235bd
1 changed files with 41 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
collects/drscheme/syncheck.ss
View File

@ -95,13 +95,23 @@ If the namespace does not, they are colored the unbound color.
(define xref 'not-yet-loaded-xref) (define xref 'not-yet-loaded-xref)
(define (get-xref) (define (get-xref)
(cond
[(equal? xref 'failed-to-load) #f]
[else
(when (symbol? xref) (when (symbol? xref)
(error 'get-xref "xref has not yet been loaded")) (error 'get-xref "xref has not yet been loaded"))
xref) xref]))
(define (force-xref th) (define (force-xref th)
(when (symbol? xref) (cond
[(equal? xref 'failed-to-load)
(void)]
[(symbol? xref)
(th) (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)) (syntax-span stx))
(let* ([start (- (syntax-position stx) 1)] (let* ([start (- (syntax-position stx) 1)]
[fin (+ start (syntax-span stx))] [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 (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 (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 (when index-entry
(send defs-text syncheck:add-background-color defs-text "navajowhite" start fin (syntax-e stx)) (send defs-text syncheck:add-background-color defs-text "navajowhite" start fin (syntax-e stx))
(send defs-text syncheck:add-menu (send defs-text syncheck:add-menu
@ -2404,7 +2416,7 @@ If the namespace does not, they are colored the unbound color.
(path->string path) (path->string path)
(if tag (if tag
(string-append "#" (uri-encode tag)) (string-append "#" (uri-encode tag))
"")))))))))))))))))))) ""))))))))))))))))))))))