suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

3.99.0.13: generalize require and provide to work with arbitrary phases

Browse Source 
svn: r8742

original commit: ba63bd6f954b4b1ce09225f4b55dbe7c3a93a46b
This commit is contained in:
Matthew Flatt 2008-02-20 14:17:37 +00:00
parent d9a438219a
commit 1cc6ff191b
4 changed files with 84 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
collects/scribble/manual.ss
View File

@ -446,7 +446,7 @@
(let ([s (to-element/no-color elem)]) (let ([s (to-element/no-color elem)])
(make-delayed-element (make-delayed-element
(lambda (renderer sec ri) (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)))] [taglet (and tag (append (cadr tag) (list elem)))]
[vtag (and tag `(sig-val ,taglet))] [vtag (and tag `(sig-val ,taglet))]
[stag (and tag `(sig-form ,taglet))] [stag (and tag `(sig-form ,taglet))]
@ -490,7 +490,7 @@
(lambda (c mk) (lambda (c mk)
(make-delayed-element (make-delayed-element
(lambda (ren p ri) (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 (if tag
(list (mk tag)) (list (mk tag))
content))) content)))
@ -1851,7 +1851,7 @@
(list (list
(make-link-element #f (make-link-element #f
content 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)))))) (format "--UNDEFINED:~a--" (syntax-e stx-id))))))
(lambda () content) (lambda () content)
(lambda () content)))) (lambda () content))))
@ -2023,15 +2023,17 @@
(if (path? p) (if (path? p)
(intern-taglet (path->main-collects-relative p)) (intern-taglet (path->main-collects-relative p))
p)) p))
(cadddr b) (list-ref b 3)
(list-ref b 5)) (list-ref b 4)
(list-ref b 5)
(list-ref b 6))
(error 'scribble "no class/interface/mixin information for identifier: ~e" (error 'scribble "no class/interface/mixin information for identifier: ~e"
id)))) id))))
(define-serializable-struct cls/intf (name-element app-mixins super intfs methods)) (define-serializable-struct cls/intf (name-element app-mixins super intfs methods))
(define (make-inherited-table r d ri decl) (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 (if key
(list (cons key (lookup-cls/intf d ri key))) (list (cons key (lookup-cls/intf d ri key)))
null))] null))]
@ -2047,7 +2049,7 @@
(let ([super (car supers)]) (let ([super (car supers)])
(loop (append (filter values (loop (append (filter values
(map (lambda (i) (map (lambda (i)
(let ([key (find-scheme-tag d ri i 'for-label)]) (let ([key (find-scheme-tag d ri i #f)])
(and key (and key
(cons key (lookup-cls/intf d ri key))))) (cons key (lookup-cls/intf d ri key)))))
(append (append
@ -2452,14 +2454,14 @@
null))]) null))])
(make-delayed-element (make-delayed-element
(lambda (r d ri) (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 (cond
[(null? search) [(null? search)
(list (make-element #f '("<method not found>")))] (list (make-element #f '("<method not found>")))]
[(not (car search)) [(not (car search))
(loop (cdr search))] (loop (cdr search))]
[else [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))]) [v (and a-key (lookup-cls/intf d ri a-key))])
(if v (if v
(if (member name (cls/intf-methods v)) (if (member name (cls/intf-methods v))
@ -2468,7 +2470,7 @@
(list (**method name a-key) (list (**method name a-key)
" in " " in "
(cls/intf-name-element v)))) (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))))]))) (loop (cdr search))))])))
(lambda () (format "~a in ~a" (syntax-e cname) name)) (lambda () (format "~a in ~a" (syntax-e cname) name))
(lambda () (format "~a in ~a" (syntax-e cname) name))))) (lambda () (format "~a in ~a" (syntax-e cname) name)))))

2
collects/scribble/scheme.ss
View File

@ -85,7 +85,7 @@
(weak-box-value b)))) (weak-box-value b))))
(let ([e (make-cached-delayed-element (let ([e (make-cached-delayed-element
(lambda (renderer sec ri) (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 (if tag
(list (list
(case (car tag) (case (car tag)

88
collects/scribble/search.ss
View File

@ -36,17 +36,21 @@
v))) v)))
;; mode is #f, 'for-label, or 'for-run (define (find-scheme-tag part ri stx/binding phase-level)
(define (find-scheme-tag part ri stx/binding mode) ;; 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 (let ([b (cond
[(identifier? stx/binding) [(identifier? stx/binding)
((case mode (identifier-binding stx/binding phase-level)]
[(for-label) identifier-label-binding]
[(for-syntax) identifier-transformer-binding]
[else identifier-binding])
stx/binding)]
[(and (list? stx/binding) [(and (list? stx/binding)
(= 6 (length stx/binding))) (= 7 (length stx/binding)))
stx/binding] stx/binding]
[else [else
(and (not (symbol? (car stx/binding))) (and (not (symbol? (car stx/binding)))
@ -57,15 +61,20 @@
(cadr stx/binding) (cadr stx/binding)
p p
(cadr stx/binding) (cadr stx/binding)
#f
(if (= 2 (length stx/binding)) (if (= 2 (length stx/binding))
mode 0
(caddr stx/binding)))))])]) (caddr stx/binding))
(if (= 2 (length stx/binding))
0
(cadddr stx/binding))
(if (= 2 (length stx/binding))
0
(cadddr (cdr stx/binding))))))])])
(and (and
(pair? b) (pair? b)
(let ([seen (make-hash-table)] (let ([seen (make-hash-table)]
[search-key #f]) [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]) [rqueue null])
(cond (cond
[(null? queue) [(null? queue)
@ -74,12 +83,14 @@
#f #f
(loop (reverse rqueue) null))] (loop (reverse rqueue) null))]
[else [else
(let ([mod (caar queue)] (let ([mod (list-ref (car queue) 0)]
[id (cadar queue)] [id (list-ref (car queue) 1)]
[here? (caddar queue)] [defn-phase (list-ref (car queue) 2)]
[import-phase (list-ref (car queue) 3)]
[export-phase (list-ref (car queue) 4)]
[queue (cdr queue)]) [queue (cdr queue)])
(let* ([rmp (module-path-index-resolve mod)] (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)]) (list (let ([p (resolved-module-path-name rmp)])
(if (path? p) (if (path? p)
(intern-taglet (path->main-collects-relative p)) (intern-taglet (path->main-collects-relative p))
@ -106,35 +117,46 @@
module-info-cache module-info-cache
rmp rmp
(lambda () (lambda ()
(let-values ([(run-vals run-stxes (let-values ([(valss stxess)
syntax-vals syntax-stxes
label-vals label-stxes)
(module-compiled-exports (module-compiled-exports
(get-module-code (resolved-module-path-name rmp)))]) (get-module-code (resolved-module-path-name rmp)))])
(let ([t (list (append run-vals run-stxes) (let ([t
(append syntax-vals syntax-stxes) ;; Merge the two association lists:
(append label-vals label-stxes))]) (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) (hash-table-put! module-info-cache rmp t)
t))))]) t))))])
(hash-table-put! seen rmp #t) (hash-table-put! seen rmp #t)
(let ([a (assq id (list-ref exports (let ([a (assq id (let ([a (assoc export-phase exports)])
(if here? (if a
0 (cdr a)
(case mode null)))])
[(for-syntax) 1]
[(for-label) 2]
[else 0]))))])
(if a (if a
(loop queue (loop queue
(append (map (lambda (m) (append (map (lambda (m)
(if (pair? m) (if (pair? m)
(list (module-path-index-rejoin (car m) mod) (list (module-path-index-rejoin (car m) mod)
(caddr m) (list-ref m 2)
(or here? defn-phase
(eq? mode (cadr m)))) (list-ref m 1)
(list-ref m 3))
(list (module-path-index-rejoin m mod) (list (module-path-index-rejoin m mod)
id id
here?))) 0
0
0)))
(cadr a)) (cadr a))
rqueue)) rqueue))
(error 'find-scheme-tag (error 'find-scheme-tag

37
collects/scribblings/scribble/xref.scrbl
View File

@ -49,15 +49,18 @@ get all cross-reference information for installed documentation.}
symbol? symbol?
module-path-index? module-path-index?
symbol? symbol?
boolean? (one-of/c 0 1)
(one-of/c #f 'for-syntax 'for-label)) (or/c exact-integer? false/c)
(or/c exact-integer? false/c))
(list/c (or/c module-path? (list/c (or/c module-path?
module-path-index? module-path-index?
path? path?
resolved-module-path?) resolved-module-path?)
symbol? symbol?
(one-of/c #f 'for-syntax 'for-label)))] (one-of/c 0 1)
[mode (one-of/c #f 'for-syntax 'for-label)]) (or/c exact-integer? false/c)
(or/c exact-integer? false/c)))]
[mode (or/c exact-integer? false/c)])
(or/c tag? false/c)]{ (or/c tag? false/c)]{
Locates a tag in @scheme[xref] that documents a module export. The 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 re-exported from other other module, for the other module
(transitively). (transitively).
The @scheme[mode] argument specifies more information about the The @scheme[mode] argument specifies the relevant phase level for the
binding: whether it refers to a normal binding, a @scheme[for-syntax] binding. The @scheme[binding] is specified in one of four ways:
binding, or a @scheme[for-label] binding.
The @scheme[binding] is specified in one of four ways:
@itemize{ @itemize{
@item{If @scheme[binding] is an identifier, then @item{If @scheme[binding] is an identifier, then
@scheme[identifier-binding], @scheme[identifier-binding] is used with @scheme[mode] to
@scheme[identifier-transformer-binding], or determine the binding.}
@scheme[identifier-label-binding] is used to determine the
binding, depending on the value of @scheme[mode].}
@item{If @scheme[binding] is a two-element list, then the first @item{If @scheme[binding] is a two-element list, then the first
element provides the exporting module and the second the element provides the exporting module and the second the
exported name. The @scheme[mode] argument is effectively exported name. The @scheme[mode] argument is effectively
ignored.} ignored.}
@item{If @scheme[binding] is a six-element list, then it corresponds @item{If @scheme[binding] is a seven-element list, then it corresponds
to a result from @scheme[identifier-binding], to a result from @scheme[identifier-binding] using
@scheme[identifier-transformer-binding], or
@scheme[identifier-label-binding], depending on the value of
@scheme[mode].} @scheme[mode].}
@item{If @scheme[binding] is a three-element list, then the first @item{If @scheme[binding] is a five-element list, then the first
element is as for the 2-element-list case, the second element element is as for the two-element-list case, and the remain
is like the fourth element of the six-element case, and the elements are as in the last four elements of the seven-element
third element is like the sixth element of the six-element
case.} case.}
} }