use new 'serialized=?' to tighten setup scribble fixpoint
svn: r10428 original commit: 3f60a478ad5e955a723d34ca970060652279fd13
This commit is contained in:
Matthew Flatt
parent
ab1949f40e
commit
0ffd48ae5e
|
|
@ -58,13 +58,14 @@
|
||||||
(let ([seen (make-hasheq)]
|
(let ([seen (make-hasheq)]
|
||||||
[search-key #f])
|
[search-key #f])
|
||||||
(let loop ([queue (list (list (caddr b) (cadddr b) (list-ref b 4) (list-ref b 5) (list-ref b 6)))]
|
(let loop ([queue (list (list (caddr b) (cadddr b) (list-ref b 4) (list-ref b 5) (list-ref b 6)))]
|
||||||
[rqueue null])
|
[rqueue null]
|
||||||
|
[need-result? #t])
|
||||||
(cond
|
(cond
|
||||||
[(null? queue)
|
[(null? queue)
|
||||||
(if (null? rqueue)
|
(if (null? rqueue)
|
||||||
;; Not documented
|
;; Not documented
|
||||||
#f
|
#f
|
||||||
(loop (reverse rqueue) null))]
|
(loop (reverse rqueue) null need-result?))]
|
||||||
[else
|
[else
|
||||||
(let ([mod (list-ref (car queue) 0)]
|
(let ([mod (list-ref (car queue) 0)]
|
||||||
[id (list-ref (car queue) 1)]
|
[id (list-ref (car queue) 1)]
|
||||||
|
|
@ -80,77 +81,86 @@
|
||||||
(not search-key))
|
(not search-key))
|
||||||
(set! search-key eb))
|
(set! search-key eb))
|
||||||
(let ([v (and eb (resolve-search search-key part ri `(dep ,eb)))])
|
(let ([v (and eb (resolve-search search-key part ri `(dep ,eb)))])
|
||||||
(or (and v
|
(let* ([here-result
|
||||||
(let ([v (resolve-get/tentative part ri `(form ,eb))])
|
(and need-result?
|
||||||
(or (and v `(form ,eb))
|
v
|
||||||
`(def ,eb))))
|
(let ([v (resolve-get/tentative part ri `(form ,eb))])
|
||||||
;; Maybe it's re-exported from this module...
|
(or (and v `(form ,eb))
|
||||||
;; Try a shortcut:
|
`(def ,eb))))]
|
||||||
(if (eq? rmp (and (car b) (module-path-index-resolve (car b))))
|
[need-result? (and need-result? (not here-result))])
|
||||||
;; Not defined through this path, so keep looking
|
;; Even if we've found `here-result', look deeper so that we have
|
||||||
(loop queue rqueue)
|
;; consistent `dep' results.
|
||||||
;; Check parents, if we can get the source:
|
(let ([nest-result
|
||||||
(if (and (path? (resolved-module-path-name rmp))
|
;; Maybe it's re-exported from this module...
|
||||||
(not (hash-ref seen rmp #f)))
|
;; Try a shortcut:
|
||||||
(let ([exports
|
(if (eq? rmp (and (car b) (module-path-index-resolve (car b))))
|
||||||
(hash-ref
|
;; Not defined through this path, so keep looking
|
||||||
module-info-cache
|
(loop queue rqueue need-result?)
|
||||||
rmp
|
;; Check parents, if we can get the source:
|
||||||
(lambda ()
|
(if (and (path? (resolved-module-path-name rmp))
|
||||||
(let-values ([(valss stxess)
|
(not (hash-ref seen rmp #f)))
|
||||||
(with-handlers ([exn:fail?
|
(let ([exports
|
||||||
(lambda (exn)
|
(hash-ref
|
||||||
(values null null))])
|
module-info-cache
|
||||||
(module-compiled-exports
|
rmp
|
||||||
(get-module-code (resolved-module-path-name rmp)
|
(lambda ()
|
||||||
#:choose (lambda (src zo so) 'zo))))])
|
(let-values ([(valss stxess)
|
||||||
(let ([t
|
(with-handlers ([exn:fail?
|
||||||
;; Merge the two association lists:
|
(lambda (exn)
|
||||||
(let loop ([base valss]
|
(values null null))])
|
||||||
[stxess stxess])
|
(module-compiled-exports
|
||||||
(cond
|
(get-module-code (resolved-module-path-name rmp)
|
||||||
[(null? stxess) base]
|
#:choose (lambda (src zo so) 'zo))))])
|
||||||
[(assoc (caar stxess) base)
|
(let ([t
|
||||||
=> (lambda (l)
|
;; Merge the two association lists:
|
||||||
(loop (cons (cons (car l)
|
(let loop ([base valss]
|
||||||
(append (cdar stxess)
|
[stxess stxess])
|
||||||
(cdr l)))
|
(cond
|
||||||
(remq l base))
|
[(null? stxess) base]
|
||||||
(cdr stxess)))]
|
[(assoc (caar stxess) base)
|
||||||
[else (loop (cons (car stxess)
|
=> (lambda (l)
|
||||||
base)
|
(loop (cons (cons (car l)
|
||||||
(cdr stxess))]))])
|
(append (cdar stxess)
|
||||||
(hash-set! module-info-cache rmp t)
|
(cdr l)))
|
||||||
t))))])
|
(remq l base))
|
||||||
(hash-set! seen rmp #t)
|
(cdr stxess)))]
|
||||||
(let ([a (assq id (let ([a (assoc export-phase exports)])
|
[else (loop (cons (car stxess)
|
||||||
(if a
|
base)
|
||||||
(cdr a)
|
(cdr stxess))]))])
|
||||||
null)))])
|
(hash-set! module-info-cache rmp t)
|
||||||
(if a
|
t))))])
|
||||||
(loop queue
|
(hash-set! seen rmp #t)
|
||||||
(append (map (lambda (m)
|
(let ([a (assq id (let ([a (assoc export-phase exports)])
|
||||||
(if (pair? m)
|
(if a
|
||||||
(list (module-path-index-rejoin (car m) mod)
|
(cdr a)
|
||||||
(list-ref m 2)
|
null)))])
|
||||||
defn-phase
|
(if a
|
||||||
(list-ref m 1)
|
(loop queue
|
||||||
(list-ref m 3))
|
(append (map (lambda (m)
|
||||||
(list (module-path-index-rejoin m mod)
|
(if (pair? m)
|
||||||
id
|
(list (module-path-index-rejoin (car m) mod)
|
||||||
0
|
(list-ref m 2)
|
||||||
0
|
defn-phase
|
||||||
0)))
|
(list-ref m 1)
|
||||||
(cadr a))
|
(list-ref m 3))
|
||||||
rqueue))
|
(list (module-path-index-rejoin m mod)
|
||||||
(begin
|
id
|
||||||
;; A dead end may not be our fault: the files could
|
0
|
||||||
;; have changed in inconsistent ways. So just say #f
|
0
|
||||||
;; for now.
|
0)))
|
||||||
#;
|
(cadr a))
|
||||||
(error 'find-scheme-tag
|
rqueue)
|
||||||
"dead end when looking for binding source: ~e"
|
need-result?)
|
||||||
id)
|
(begin
|
||||||
#f))))
|
;; A dead end may not be our fault: the files could
|
||||||
;; Can't get the module source, so continue with queue:
|
;; have changed in inconsistent ways. So just say #f
|
||||||
(loop queue rqueue)))))))])))))))
|
;; for now.
|
||||||
|
#;
|
||||||
|
(error 'find-scheme-tag
|
||||||
|
"dead end when looking for binding source: ~e"
|
||||||
|
id)
|
||||||
|
#f))))
|
||||||
|
;; Can't get the module source, so continue with queue:
|
||||||
|
(loop queue rqueue need-result?)))])
|
||||||
|
(or here-result
|
||||||
|
nest-result))))))])))))))
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user