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

revise scribble/srcdoc so it is extensible; tweak bytecode optimizer to drop more omittable expressions

Browse Source 
svn: r9028

original commit: f5e0fd35f53eddf5e51843542103f5ea85d429a2
This commit is contained in:
Matthew Flatt 2008-03-19 19:53:51 +00:00
parent 6c435c4e12
commit 4809dfdeb5
4 changed files with 148 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
collects/scribble/extract.ss
View File

@ -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-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-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 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)))])))

28
collects/scribble/manual.ss
View File

@ -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)

15
collects/scribble/provide-doc-transform.ss Normal file
View File

@ -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)))

90
collects/scribble/srcdoc.ss
View File

@ -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]))