commit 1cc6ff191bd96ed79a61d5f7a6aecb31dfe02e22
parent d9a438219ab2daf64728875a6bfc4f96dff38da6
Author: Matthew Flatt <mflatt@racket-lang.org>
Date: Wed, 20 Feb 2008 14:17:37 +0000
3.99.0.13: generalize require and provide to work with arbitrary phases
svn: r8742
original commit: ba63bd6f954b4b1ce09225f4b55dbe7c3a93a46b
Diffstat:
4 files changed, 84 insertions(+), 65 deletions(-)
diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss
@@ -446,7 +446,7 @@
(let ([s (to-element/no-color elem)])
(make-delayed-element
(lambda (renderer sec ri)
- (let* ([tag (find-scheme-tag sec ri sig 'for-label)]
+ (let* ([tag (find-scheme-tag sec ri sig #f)]
[taglet (and tag (append (cadr tag) (list elem)))]
[vtag (and tag `(sig-val ,taglet))]
[stag (and tag `(sig-form ,taglet))]
@@ -490,7 +490,7 @@
(lambda (c mk)
(make-delayed-element
(lambda (ren p ri)
- (let ([tag (find-scheme-tag p ri id/tag 'for-label)])
+ (let ([tag (find-scheme-tag p ri id/tag #f)])
(if tag
(list (mk tag))
content)))
@@ -1851,7 +1851,7 @@
(list
(make-link-element #f
content
- (or (find-scheme-tag p ri stx-id 'for-label)
+ (or (find-scheme-tag p ri stx-id #f)
(format "--UNDEFINED:~a--" (syntax-e stx-id))))))
(lambda () content)
(lambda () content))))
@@ -2023,15 +2023,17 @@
(if (path? p)
(intern-taglet (path->main-collects-relative p))
p))
- (cadddr b)
- (list-ref b 5))
+ (list-ref b 3)
+ (list-ref b 4)
+ (list-ref b 5)
+ (list-ref b 6))
(error 'scribble "no class/interface/mixin information for identifier: ~e"
id))))
(define-serializable-struct cls/intf (name-element app-mixins super intfs methods))
(define (make-inherited-table r d ri decl)
- (let* ([start (let ([key (find-scheme-tag d ri (decl-name decl) 'for-label)])
+ (let* ([start (let ([key (find-scheme-tag d ri (decl-name decl) #f)])
(if key
(list (cons key (lookup-cls/intf d ri key)))
null))]
@@ -2047,7 +2049,7 @@
(let ([super (car supers)])
(loop (append (filter values
(map (lambda (i)
- (let ([key (find-scheme-tag d ri i 'for-label)])
+ (let ([key (find-scheme-tag d ri i #f)])
(and key
(cons key (lookup-cls/intf d ri key)))))
(append
@@ -2452,14 +2454,14 @@
null))])
(make-delayed-element
(lambda (r d ri)
- (let loop ([search (get d ri (find-scheme-tag d ri cname 'for-label))])
+ (let loop ([search (get d ri (find-scheme-tag d ri cname #f))])
(cond
[(null? search)
(list (make-element #f '("<method not found>")))]
[(not (car search))
(loop (cdr search))]
[else
- (let* ([a-key (find-scheme-tag d ri (car search) 'for-label)]
+ (let* ([a-key (find-scheme-tag d ri (car search) #f)]
[v (and a-key (lookup-cls/intf d ri a-key))])
(if v
(if (member name (cls/intf-methods v))
@@ -2468,7 +2470,7 @@
(list (**method name a-key)
" in "
(cls/intf-name-element v))))
- (loop (append (cdr search) (get d ri (find-scheme-tag d ri (car search) 'for-label)))))
+ (loop (append (cdr search) (get d ri (find-scheme-tag d ri (car search) #f)))))
(loop (cdr search))))])))
(lambda () (format "~a in ~a" (syntax-e cname) name))
(lambda () (format "~a in ~a" (syntax-e cname) name)))))
diff --git a/collects/scribble/scheme.ss b/collects/scribble/scheme.ss
@@ -85,7 +85,7 @@
(weak-box-value b))))
(let ([e (make-cached-delayed-element
(lambda (renderer sec ri)
- (let* ([tag (find-scheme-tag sec ri c 'for-label)])
+ (let* ([tag (find-scheme-tag sec ri c #f)])
(if tag
(list
(case (car tag)
diff --git a/collects/scribble/search.ss b/collects/scribble/search.ss
@@ -36,17 +36,21 @@
v)))
- ;; mode is #f, 'for-label, or 'for-run
- (define (find-scheme-tag part ri stx/binding mode)
+ (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 key 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.
(let ([b (cond
[(identifier? stx/binding)
- ((case mode
- [(for-label) identifier-label-binding]
- [(for-syntax) identifier-transformer-binding]
- [else identifier-binding])
- stx/binding)]
+ (identifier-binding stx/binding phase-level)]
[(and (list? stx/binding)
- (= 6 (length stx/binding)))
+ (= 7 (length stx/binding)))
stx/binding]
[else
(and (not (symbol? (car stx/binding)))
@@ -57,15 +61,20 @@
(cadr stx/binding)
p
(cadr stx/binding)
- #f
(if (= 2 (length stx/binding))
- mode
- (caddr 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-hash-table)]
[search-key #f])
- (let loop ([queue (list (list (caddr b) (cadddr b) (eq? mode (list-ref b 5))))]
+ (let loop ([queue (list (list (caddr b) (cadddr b) (list-ref b 4) (list-ref b 5) (list-ref b 6)))]
[rqueue null])
(cond
[(null? queue)
@@ -74,12 +83,14 @@
#f
(loop (reverse rqueue) null))]
[else
- (let ([mod (caar queue)]
- [id (cadar queue)]
- [here? (caddar queue)]
+ (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 here?
+ [eb (and (equal? defn-phase export-phase)
(list (let ([p (resolved-module-path-name rmp)])
(if (path? p)
(intern-taglet (path->main-collects-relative p))
@@ -106,35 +117,46 @@
module-info-cache
rmp
(lambda ()
- (let-values ([(run-vals run-stxes
- syntax-vals syntax-stxes
- label-vals label-stxes)
+ (let-values ([(valss stxess)
(module-compiled-exports
(get-module-code (resolved-module-path-name rmp)))])
- (let ([t (list (append run-vals run-stxes)
- (append syntax-vals syntax-stxes)
- (append label-vals label-stxes))])
+ (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-table-put! module-info-cache rmp t)
t))))])
(hash-table-put! seen rmp #t)
- (let ([a (assq id (list-ref exports
- (if here?
- 0
- (case mode
- [(for-syntax) 1]
- [(for-label) 2]
- [else 0]))))])
+ (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)
- (caddr m)
- (or here?
- (eq? mode (cadr m))))
+ (list-ref m 2)
+ defn-phase
+ (list-ref m 1)
+ (list-ref m 3))
(list (module-path-index-rejoin m mod)
id
- here?)))
+ 0
+ 0
+ 0)))
(cadr a))
rqueue))
(error 'find-scheme-tag
diff --git a/collects/scribblings/scribble/xref.scrbl b/collects/scribblings/scribble/xref.scrbl
@@ -49,15 +49,18 @@ get all cross-reference information for installed documentation.}
symbol?
module-path-index?
symbol?
- boolean?
- (one-of/c #f 'for-syntax 'for-label))
+ (one-of/c 0 1)
+ (or/c exact-integer? false/c)
+ (or/c exact-integer? false/c))
(list/c (or/c module-path?
module-path-index?
path?
resolved-module-path?)
symbol?
- (one-of/c #f 'for-syntax 'for-label)))]
- [mode (one-of/c #f 'for-syntax 'for-label)])
+ (one-of/c 0 1)
+ (or/c exact-integer? false/c)
+ (or/c exact-integer? false/c)))]
+ [mode (or/c exact-integer? false/c)])
(or/c tag? false/c)]{
Locates a tag in @scheme[xref] that documents a module export. The
@@ -68,35 +71,27 @@ either for the specified module or, if the exported name is
re-exported from other other module, for the other module
(transitively).
-The @scheme[mode] argument specifies more information about the
-binding: whether it refers to a normal binding, a @scheme[for-syntax]
-binding, or a @scheme[for-label] binding.
-
-The @scheme[binding] is specified in one of four ways:
+The @scheme[mode] argument specifies the relevant phase level for the
+binding. The @scheme[binding] is specified in one of four ways:
@itemize{
@item{If @scheme[binding] is an identifier, then
- @scheme[identifier-binding],
- @scheme[identifier-transformer-binding], or
- @scheme[identifier-label-binding] is used to determine the
- binding, depending on the value of @scheme[mode].}
+ @scheme[identifier-binding] is used with @scheme[mode] to
+ determine the binding.}
@item{If @scheme[binding] is a two-element list, then the first
element provides the exporting module and the second the
exported name. The @scheme[mode] argument is effectively
ignored.}
- @item{If @scheme[binding] is a six-element list, then it corresponds
- to a result from @scheme[identifier-binding],
- @scheme[identifier-transformer-binding], or
- @scheme[identifier-label-binding], depending on the value of
+ @item{If @scheme[binding] is a seven-element list, then it corresponds
+ to a result from @scheme[identifier-binding] using
@scheme[mode].}
- @item{If @scheme[binding] is a three-element list, then the first
- element is as for the 2-element-list case, the second element
- is like the fourth element of the six-element case, and the
- third element is like the sixth element of the six-element
+ @item{If @scheme[binding] is a five-element list, then the first
+ element is as for the two-element-list case, and the remain
+ elements are as in the last four elements of the seven-element
case.}
}
