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

fix bug in tracking nominal imporst (which is why the version changed), add EoPL scribblings and fix browser scribblings

Browse Source 
svn: r8633

original commit: 86b0c9909a64ffdb589b8868f89fee89ee92f564
This commit is contained in:
Matthew Flatt 2008-02-12 14:59:05 +00:00
parent 71e67c4bf0
commit d29d7ef3b0
1 changed files with 54 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

79
collects/scribble/manual.ss
View File

@ -584,20 +584,25 @@
(define-syntax (quote-syntax/loc stx) (define-syntax (quote-syntax/loc stx)
(syntax-case stx () (syntax-case stx ()
[(_ id) [(_ id)
(with-syntax ([loc (with-syntax ([loc
(let ([s #'id]) (let ([s #'id])
(list (syntax-source s) (vector (syntax-source s)
(syntax-line s) (syntax-line s)
(syntax-column s) (syntax-column s)
(syntax-position s) (syntax-position s)
(syntax-span s)))]) (syntax-span s)))])
#'(let ([s (quote-syntax id)]) #'(let ([s (*quote-syntax/loc id)])
(datum->syntax s (datum->syntax s
(syntax-e s) (syntax-e s)
'loc 'loc
s)))])) s)))]))
(define-syntax *quote-syntax/loc
(syntax-rules ()
[(_ (sub ...)) (datum->syntax #f (list (quote-syntax/loc sub) ...))]
[(_ id) (quote-syntax id)]))
(define void-const (define void-const
(schemeresultfont "#<void>")) (schemeresultfont "#<void>"))
(define undefined-const (define undefined-const
@ -1981,7 +1986,7 @@
(define-syntax-parameter current-class #f) (define-syntax-parameter current-class #f)
(define-struct decl (name super intfs ranges mk-head body)) (define-struct decl (name super app-mixins intfs ranges mk-head body))
(define-struct constructor (def)) (define-struct constructor (def))
(define-struct meth (name mode desc def)) (define-struct meth (name mode desc def))
(define-struct spec (def)) (define-struct spec (def))
@ -1989,14 +1994,17 @@
(define (id-info id) (define (id-info id)
(let ([b (identifier-label-binding id)]) (let ([b (identifier-label-binding id)])
(list (let ([p (resolved-module-path-name (module-path-index-resolve (caddr b)))]) (if b
(if (path? p) (list (let ([p (resolved-module-path-name (module-path-index-resolve (caddr b)))])
(intern-taglet (path->main-collects-relative p)) (if (path? p)
p)) (intern-taglet (path->main-collects-relative p))
(cadddr b) p))
(list-ref b 5)))) (cadddr b)
(list-ref b 5))
(error 'scribble "no class/interface/mixin information for identifier: ~e"
id))))
(define-serializable-struct cls/intf (name-element 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) 'for-label)])
@ -2018,12 +2026,12 @@
(let ([key (find-scheme-tag d ri i 'for-label)]) (let ([key (find-scheme-tag d ri i 'for-label)])
(and key (and key
(cons key (lookup-cls/intf d ri key))))) (cons key (lookup-cls/intf d ri key)))))
(reverse (cls/intf-intfs (cdr super))))) (append
(let ([s (and (cls/intf-super (cdr super)) (reverse (cls/intf-intfs (cdr super)))
(find-scheme-tag d ri (cls/intf-super (cdr super)) 'for-label))]) (if (cls/intf-super (cdr super))
(if s (list (cls/intf-super (cdr super)))
(list (cons s (lookup-cls/intf d ri s))) null)
null)) (reverse (cls/intf-app-mixins (cdr super))))))
(cdr supers)) (cdr supers))
(cons super accum)))]))))] (cons super accum)))]))))]
[ht (let ([ht (make-hash-table)]) [ht (let ([ht (make-hash-table)])
@ -2080,6 +2088,7 @@
"schemevaluelink" "schemevaluelink"
(list (symbol->string (syntax-e (decl-name decl)))) (list (symbol->string (syntax-e (decl-name decl))))
tag))) tag)))
(map id-info (decl-app-mixins decl))
(and (decl-super decl) (and (decl-super decl)
(not (free-label-identifier=? (quote-syntax object%) (not (free-label-identifier=? (quote-syntax object%)
(decl-super decl))) (decl-super decl)))
@ -2194,20 +2203,36 @@
(show-intfs intfs #f) (show-intfs intfs #f)
(show-intfs ranges #t))))))) (show-intfs ranges #t)))))))
(define-syntax extract-super
(syntax-rules ()
[(_ (mixin base))
(extract-super base)]
[(_ super)
(quote-syntax/loc super)]))
(define-syntax extract-app-mixins
(syntax-rules ()
[(_ (mixin base))
(cons (quote-syntax/loc mixin)
(extract-app-mixins base))]
[(_ super)
null]))
(define-syntax *defclass (define-syntax *defclass
(syntax-rules () (syntax-rules ()
[(_ *include-class name super (intf ...) body ...) [(_ *include-class name super (intf ...) body ...)
(*include-class (*include-class
(syntax-parameterize ([current-class (quote-syntax name)]) (syntax-parameterize ([current-class (quote-syntax name)])
(make-decl (quote-syntax/loc name) (make-decl (quote-syntax/loc name)
(quote-syntax/loc super) (extract-super super)
(extract-app-mixins super)
(list (quote-syntax/loc intf) ...) (list (quote-syntax/loc intf) ...)
null null
(lambda (whole-page?) (lambda (whole-page?)
(list (list
(*class-doc 'class (*class-doc 'class
(quote-syntax/loc name) (quote-syntax/loc name)
(quote-syntax super) (quote-syntax/loc super)
(list (quote-syntax intf) ...) (list (quote-syntax intf) ...)
null null
whole-page? whole-page?
@ -2231,6 +2256,7 @@
(syntax-parameterize ([current-class (quote-syntax name)]) (syntax-parameterize ([current-class (quote-syntax name)])
(make-decl (quote-syntax/loc name) (make-decl (quote-syntax/loc name)
#f #f
null
(list (quote-syntax/loc intf) ...) (list (quote-syntax/loc intf) ...)
null null
(lambda (whole-page?) (lambda (whole-page?)
@ -2261,6 +2287,7 @@
(syntax-parameterize ([current-class (quote-syntax name)]) (syntax-parameterize ([current-class (quote-syntax name)])
(make-decl (quote-syntax/loc name) (make-decl (quote-syntax/loc name)
#f #f
null
(list (quote-syntax/loc domain) ...) (list (quote-syntax/loc domain) ...)
(list (quote-syntax/loc range) ...) (list (quote-syntax/loc range) ...)
(lambda (whole-page?) (lambda (whole-page?)
@ -2394,8 +2421,9 @@
(if key (if key
(let ([v (lookup-cls/intf d ri key)]) (let ([v (lookup-cls/intf d ri key)])
(if v (if v
(cons (cls/intf-super v) (append (cls/intf-app-mixins v)
(cls/intf-intfs v)) (cons (cls/intf-super v)
(cls/intf-intfs v)))
null)) null))
null))]) null))])
(make-delayed-element (make-delayed-element
@ -2425,6 +2453,7 @@
(let ([v (resolve-get d ri `(cls/intf ,(cadr tag)))]) (let ([v (resolve-get d ri `(cls/intf ,(cadr tag)))])
(or v (or v
(make-cls/intf "unknown" (make-cls/intf "unknown"
null
#f #f
null null
null)))) null))))