commit 4809dfdeb5783ca3f74f00970584706cc0e0a6dd
parent 6c435c4e121e83ad8bdfe680392939bf3225715c
Author: Matthew Flatt <mflatt@racket-lang.org>
Date: Wed, 19 Mar 2008 19:53:51 +0000
revise scribble/srcdoc so it is extensible; tweak bytecode optimizer to drop more omittable expressions
svn: r9028
original commit: f5e0fd35f53eddf5e51843542103f5ea85d429a2
Diffstat:
4 files changed, 148 insertions(+), 37 deletions(-)
diff --git a/collects/scribble/extract.ss b/collects/scribble/extract.ss
@@ -35,16 +35,14 @@
(mod-beg
content ...))
(with-syntax ([(content ...)
- (map
- strip-context
- (apply
- append
- (map (lambda (c)
- (syntax-case c (#%plain-app void quote-syntax provide/doc)
- [(#%plain-app void (quote-syntax (provide/doc spec ...)))
- (syntax->list #'(spec ...))]
- [_ null]))
- (syntax->list #'(content ...)))))]
+ (apply
+ append
+ (map (lambda (c)
+ (syntax-case c (#%plain-app void quote-syntax provide/doc)
+ [(#%plain-app void (quote-syntax (provide/doc spec ...)))
+ (syntax->list #'(spec ...))]
+ [_ null]))
+ (syntax->list #'(content ...))))]
[(req ...)
(map
strip-context
@@ -57,16 +55,34 @@
[(#%plain-app void (quote-syntax (require/doc spec ...)))
(syntax->list #'(spec ...))]
[_ null]))
- (syntax->list #'(content ...)))))])
+ (syntax->list #'(content ...)))))]
+ [orig-tag (datum->syntax #f 'orig)])
#`(begin
(#%require (for-label #,(strip-context #'lang))
(for-label #,(strip-context #'orig-path))
req ...)
- (def-it content) ...))])))]))
+ (def-it orig-tag content) ...))])))]))
+
+(define-for-syntax (revise-context c orig-tag new-tag tag)
+ (cond
+ [(syntax? c)
+ (datum->syntax
+ (if (bound-identifier=? tag (datum->syntax c 'tag))
+ new-tag
+ orig-tag)
+ (revise-context (syntax-e c) orig-tag new-tag tag)
+ c)]
+ [(pair? c) (cons (revise-context (car c) orig-tag new-tag tag)
+ (revise-context (cdr c) orig-tag new-tag tag))]
+ [else c]))
-(define-syntax def-it
- (syntax-rules ()
- [(_ ((rename old-id id) contract desc))
- (def-it (id contract desc))]
- [(_ (id (-> arg ... result) desc))
- (defproc (id arg ...) result . desc)]))
+(define-syntax (def-it stx)
+ (syntax-local-introduce
+ (syntax-case (syntax-local-introduce stx) ()
+ [(_ orig-path (reqs doc tag))
+ (let ([new-tag ((make-syntax-introducer)
+ (datum->syntax #'orig-path 'new-tag))]
+ [orig-tag #'orig-path])
+ #`(begin
+ (require . #,(revise-context #'reqs orig-tag new-tag #'tag))
+ #,(revise-context #'doc orig-tag new-tag #'tag)))])))
diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss
@@ -713,7 +713,9 @@
(raise-syntax-error 'defproc "bad prototype" stx)]))
(define-syntax (result-contract stx)
- (syntax-case stx ()
+ (syntax-case stx (values)
+ [(_ (values c ...))
+ #'(list (schemeblock0 c) ...)]
[(_ c)
(if (string? (syntax-e #'c))
(raise-syntax-error
@@ -1233,7 +1235,29 @@
(element-width tagged))]
[(short?) (or (flat-size . < . 40)
((length args) . < . 2))]
- [(res) (result-contract)]
+ [(res) (let ([res (result-contract)])
+ (if (list? res)
+ ;; multiple results
+ (if (null? res)
+ 'nbsp
+ (let ([w (apply max 0 (map flow-element-width res))])
+ (if (or (ormap table? res)
+ (w . > . 30))
+ (make-table
+ #f
+ (map (lambda (fe)
+ (list (make-flow (list fe))))
+ res))
+ (make-table
+ #f
+ (list
+ (let loop ([res res])
+ (if (null? (cdr res))
+ (list (make-flow (list (car res))))
+ (list* (make-flow (list (car res)))
+ (to-flow (hspace 1))
+ (loop (cdr res))))))))))
+ res))]
[(result-next-line?) ((+ (if short?
flat-size
(+ (prototype-size args max max)
diff --git a/collects/scribble/provide-doc-transform.ss b/collects/scribble/provide-doc-transform.ss
@@ -0,0 +1,15 @@
+#lang scheme/base
+
+(require (for-syntax scheme/base))
+
+(provide define-provide/doc-transformer
+ (for-syntax
+ provide/doc-transformer?
+ provide/doc-transformer-proc))
+
+(begin-for-syntax
+ (define-struct provide/doc-transformer (proc) #:omit-define-syntaxes))
+
+(define-syntax-rule (define-provide/doc-transformer id rhs)
+ (define-syntax id
+ (make-provide/doc-transformer rhs)))
diff --git a/collects/scribble/srcdoc.ss b/collects/scribble/srcdoc.ss
@@ -1,27 +1,83 @@
#lang scheme/base
-(require scheme/contract)
+(require scheme/contract
+ (for-syntax scheme/base)
+ "provide-doc-transform.ss")
(provide require/doc
- provide/doc)
+ provide/doc
+ proc-doc)
(define-syntax-rule (require/doc spec ...)
(void (quote-syntax (require/doc spec ...))))
-(define-syntax-rule (provide/doc [id contract desc] ...)
- (begin
- (void (quote-syntax (provide/doc [id contract desc] ...)))
- (provide/contracted [id (strip-names contract)]) ...))
+(define-syntax (provide/doc stx)
+ (syntax-case stx ()
+ [(_ form ...)
+ (let ([forms (syntax->list #'(form ...))])
+ (with-syntax ([((for-provide/contract for-docs) ...)
+ (map (lambda (form)
+ (syntax-case form ()
+ [(id . _)
+ (identifier? #'id)
+ (let ([t (syntax-local-value #'id (lambda () #f))])
+ (unless (provide/doc-transformer? t)
+ (raise-syntax-error
+ #f
+ "not bound as a provide/doc transformer"
+ stx
+ #'id))
+ (let* ([i (make-syntax-introducer)]
+ [i2 (lambda (x) (syntax-local-introduce (i x)))])
+ (let-values ([(p/c d req/d) ((provide/doc-transformer-proc t)
+ (i (syntax-local-introduce form)))])
+ (list (i2 p/c) (list (i2 req/d) (i2 d) (i2 (quote-syntax tag)))))))]
+ [_
+ (raise-syntax-error
+ #f
+ "not a provide/doc sub-form"
+ stx
+ form)]))
+ forms)])
+ (with-syntax ([(p/c ...)
+ (map (lambda (form f)
+ (quasisyntax/loc form
+ (provide/contract #,f)))
+ forms
+ (syntax->list #'(for-provide/contract ...)))])
+ #'(begin
+ p/c ...
+ (void (quote-syntax (provide/doc for-docs ...)))))))]))
-(define-syntax provide/contracted
- (syntax-rules (->)
- [(_ [(rename orig-id new-id) contract])
- (provide/contract (rename orig-id new-id contract))]
- [(_ [id contract])
- (provide/contract [id contract])]))
+(define-provide/doc-transformer proc-doc
+ (lambda (stx)
+ (syntax-case stx ()
+ [(_ id contract desc)
+ (with-syntax ([(arg ...)
+ (syntax-case #'contract (->d)
+ [(->d (req ...) () result)
+ #'(req ...)]
+ [else
+ (raise-syntax-error
+ #f
+ "unsupported procedure contract form (arguments)"
+ stx
+ #'contract)])]
+ [result
+ (syntax-case #'contract (->d)
+ [(->d reqs opts (values [name res] ...))
+ #'(values res ...)]
+ [(->d reqs opts [name res])
+ #'res]
+ [else
+ (raise-syntax-error
+ #f
+ "unsupported procedure contract form (arguments)"
+ stx
+ #'contract)])])
+ (values
+ #'[id contract]
+ #'(defproc (id arg ...) result . desc)
+ #'(scribble/manual)))])))
-(define-syntax strip-names
- (syntax-rules (->)
- [(_ (-> [id contract] ... result))
- (-> contract ... result)]
- [(_ other) other]))
+
