167 lines
9.4 KiB
Scheme
167 lines
9.4 KiB
Scheme
(module search scheme/base
|
|
(require "struct.ss"
|
|
"basic.ss"
|
|
setup/main-collects
|
|
syntax/modcode)
|
|
|
|
(provide find-scheme-tag)
|
|
|
|
(define module-info-cache (make-hasheq))
|
|
|
|
(define (module-path-index-rejoin mpi rel-to)
|
|
(let-values ([(name base) (module-path-index-split mpi)])
|
|
(cond
|
|
[(not name) rel-to]
|
|
[(not base) mpi]
|
|
[else
|
|
(module-path-index-join name
|
|
(module-path-index-rejoin base rel-to))])))
|
|
|
|
(define (find-scheme-tag part ri stx/binding phase-level)
|
|
;; The phase-level argument is used only when `stx/binding'
|
|
;; is an identifier.
|
|
;;
|
|
;; Note: documentation keys currently don't distinguish different
|
|
;; phase definitions of an identifier from a source module.
|
|
;; That is, there's no way to document (define x ....) differently
|
|
;; from (define-for-syntax x ...). This isn't a problem in practice,
|
|
;; because no one uses the same name for different-phase exported
|
|
;; bindings.
|
|
;;
|
|
;; However, we assume that bidings are defined as originating from some
|
|
;; module at phase 0. Maybe it's defined at phase 1 and re-exported
|
|
;; later for phase 0 (after a require-for-template), in which case the
|
|
;; re-exporting module is the one we find.
|
|
(let ([b (cond
|
|
[(identifier? stx/binding)
|
|
(identifier-binding stx/binding phase-level)]
|
|
[(and (list? stx/binding)
|
|
(= 7 (length stx/binding)))
|
|
stx/binding]
|
|
[else
|
|
(and (not (symbol? (car stx/binding)))
|
|
(list #f
|
|
(cadr stx/binding)
|
|
(car stx/binding)
|
|
(cadr stx/binding)
|
|
(if (= 2 (length stx/binding))
|
|
0
|
|
(caddr stx/binding))
|
|
(if (= 2 (length stx/binding))
|
|
0
|
|
(cadddr stx/binding))
|
|
(if (= 2 (length stx/binding))
|
|
0
|
|
(cadddr (cdr stx/binding)))))])])
|
|
(and
|
|
(pair? b)
|
|
(let ([seen (make-hasheq)]
|
|
[search-key #f])
|
|
(let loop ([queue (list (list (caddr b) (cadddr b) (list-ref b 4) (list-ref b 5) (list-ref b 6)))]
|
|
[rqueue null]
|
|
[need-result? #t])
|
|
(cond
|
|
[(null? queue)
|
|
(if (null? rqueue)
|
|
;; Not documented
|
|
#f
|
|
(loop (reverse rqueue) null need-result?))]
|
|
[else
|
|
(let ([mod (list-ref (car queue) 0)]
|
|
[id (list-ref (car queue) 1)]
|
|
[defn-phase (list-ref (car queue) 2)]
|
|
[import-phase (list-ref (car queue) 3)]
|
|
[export-phase (list-ref (car queue) 4)]
|
|
[queue (cdr queue)])
|
|
(let* ([rmp (module-path-index-resolve mod)]
|
|
[eb (and (equal? 0 export-phase) ;; look for the phase-0 export; good idea?
|
|
(list (module-path-index->taglet mod)
|
|
id))])
|
|
(when (and eb
|
|
(not search-key))
|
|
(set! search-key eb))
|
|
(let ([v (and eb (resolve-search search-key part ri `(dep ,eb)))])
|
|
(let* ([here-result
|
|
(and need-result?
|
|
v
|
|
(let ([v (resolve-get/tentative part ri `(form ,eb))])
|
|
(or (and v `(form ,eb))
|
|
`(def ,eb))))]
|
|
[need-result? (and need-result? (not here-result))])
|
|
;; Even if we've found `here-result', look deeper so that we have
|
|
;; consistent `dep' results.
|
|
(let ([nest-result
|
|
;; Maybe it's re-exported from this module...
|
|
;; Try a shortcut:
|
|
(if (eq? rmp (and (car b) (module-path-index-resolve (car b))))
|
|
;; Not defined through this path, so keep looking
|
|
(loop queue rqueue need-result?)
|
|
;; Check parents, if we can get the source:
|
|
(if (and (path? (resolved-module-path-name rmp))
|
|
(not (hash-ref seen rmp #f)))
|
|
(let ([exports
|
|
(hash-ref
|
|
module-info-cache
|
|
rmp
|
|
(lambda ()
|
|
(let-values ([(valss stxess)
|
|
(with-handlers ([exn:fail?
|
|
(lambda (exn)
|
|
(values null null))])
|
|
(module-compiled-exports
|
|
(get-module-code (resolved-module-path-name rmp)
|
|
#:choose (lambda (src zo so) 'zo))))])
|
|
(let ([t
|
|
;; Merge the two association lists:
|
|
(let loop ([base valss]
|
|
[stxess stxess])
|
|
(cond
|
|
[(null? stxess) base]
|
|
[(assoc (caar stxess) base)
|
|
=> (lambda (l)
|
|
(loop (cons (cons (car l)
|
|
(append (cdar stxess)
|
|
(cdr l)))
|
|
(remq l base))
|
|
(cdr stxess)))]
|
|
[else (loop (cons (car stxess)
|
|
base)
|
|
(cdr stxess))]))])
|
|
(hash-set! module-info-cache rmp t)
|
|
t))))])
|
|
(hash-set! seen rmp #t)
|
|
(let ([a (assq id (let ([a (assoc export-phase exports)])
|
|
(if a
|
|
(cdr a)
|
|
null)))])
|
|
(if a
|
|
(loop queue
|
|
(append (map (lambda (m)
|
|
(if (pair? m)
|
|
(list (module-path-index-rejoin (car m) mod)
|
|
(list-ref m 2)
|
|
defn-phase
|
|
(list-ref m 1)
|
|
(list-ref m 3))
|
|
(list (module-path-index-rejoin m mod)
|
|
id
|
|
0
|
|
0
|
|
0)))
|
|
(cadr a))
|
|
rqueue)
|
|
need-result?)
|
|
(begin
|
|
;; A dead end may not be our fault: the files could
|
|
;; have changed in inconsistent ways. So just say #f
|
|
;; 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))))))])))))))
|