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

scribble/manual: add #:id' option to defproc'

Browse Source 
Also, convert the implementation of `defproc', `defform', etc. to
use `syntax-parse'.

original commit: 6028a60f6588f11dfe1b466df24513256e1b84c4
This commit is contained in:
Matthew Flatt 2012-06-25 23:16:33 -06:00
parent 378f9c3bae
commit 937d4f0e59
3 changed files with 231 additions and 302 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

352
collects/scribble/private/manual-form.rkt
View File

@ -10,7 +10,9 @@
"manual-scheme.rkt" "manual-scheme.rkt"
"manual-bind.rkt" "manual-bind.rkt"
scheme/list scheme/list
(for-syntax scheme/base) (for-syntax scheme/base
syntax/parse
racket/syntax)
(for-label scheme/base)) (for-label scheme/base))
(provide defform defform* defform/subs defform*/subs defform/none (provide defform defform* defform/subs defform*/subs defform/none
@ -24,17 +26,53 @@
[racketgrammar* schemegrammar*]) [racketgrammar* schemegrammar*])
var svar) var svar)
(begin-for-syntax
(define-splicing-syntax-class kind-kw
#:description "#:kind keyword"
(pattern (~optional (~seq #:kind kind)
#:defaults ([kind #'#f]))))
(define-splicing-syntax-class id-kw
#:description "#:id keyword"
(pattern (~seq #:id [defined-id:id defined-id-expr]))
(pattern (~seq #:id defined-id:id)
#:with defined-id-expr #'(quote-syntax defined-id))
(pattern (~seq #:id [#f #f])
#:with defined-id #'#f
#:with defined-id-expr #'#f)
(pattern (~seq)
#:with defined-id #'#f
#:with defined-id-expr #'#f))
(define-splicing-syntax-class literals-kw
#:description "#:literals keyword"
(pattern (~optional (~seq #:literals (lit:id ...))
#:defaults ([(lit 1) '()]))))
(define-splicing-syntax-class contracts-kw
#:description "#:contracts keyword"
(pattern (~optional (~seq #:contracts ([contract-nonterm:id contract-expr] ...))
#:defaults ([(contract-nonterm 1) '()]
[(contract-expr 1) '()]))))
(define-syntax-class grammar
(pattern ([non-term-id:id non-term-form ...] ...)))
)
(define-syntax (defform*/subs stx) (define-syntax (defform*/subs stx)
(syntax-case stx () (syntax-parse stx
[(_ #:kind kind #:id defined-id #:literals (lit ...) [spec spec1 ...] [(_ k:kind-kw d:id-kw l:literals-kw [spec spec1 ...]
([non-term-id non-term-form ...] ...) g:grammar
#:contracts ([contract-nonterm contract-expr] ...) c:contracts-kw
desc ...) desc ...)
(with-syntax ([(defined-id defined-id-expr) (with-syntax* ([defined-id (if (syntax-e #'d.defined-id)
(if (identifier? #'defined-id) #'d.defined-id
(syntax [defined-id (quote-syntax defined-id)]) (syntax-case #'spec ()
#'defined-id)]) [(spec-id . _) #'spec-id]))]
(with-syntax ([new-spec [defined-id-expr (if (syntax-e #'d.defined-id-expr)
#'d.defined-id-expr
#'(quote-syntax defined-id))]
[new-spec
(let loop ([spec #'spec]) (let loop ([spec #'spec])
(if (and (identifier? spec) (if (and (identifier? spec)
(free-identifier=? spec #'defined-id)) (free-identifier=? spec #'defined-id))
@ -46,204 +84,65 @@
spec spec
spec)] spec)]
[_ spec])))]) [_ spec])))])
(for-each (lambda (id)
(unless (identifier? id)
(raise-syntax-error #f
"expected an identifier for a literal"
stx
id)))
(syntax->list #'(lit ...)))
#'(with-togetherable-racket-variables #'(with-togetherable-racket-variables
(lit ...) (l.lit ...)
([form [defined-id spec]] [form [defined-id spec1]] ... ([form [defined-id spec]] [form [defined-id spec1]] ...
[non-term (non-term-id non-term-form ...)] ...) [non-term (g.non-term-id g.non-term-form ...)] ...)
(*defforms kind defined-id-expr (*defforms k.kind defined-id-expr
'(spec spec1 ...) '(spec spec1 ...)
(list (lambda (x) (racketblock0/form new-spec)) (list (lambda (x) (racketblock0/form new-spec))
(lambda (ignored) (racketblock0/form spec1)) ...) (lambda (ignored) (racketblock0/form spec1)) ...)
'((non-term-id non-term-form ...) ...) '((g.non-term-id g.non-term-form ...) ...)
(list (list (lambda () (racket non-term-id)) (list (list (lambda () (racket g.non-term-id))
(lambda () (racketblock0/form non-term-form)) (lambda () (racketblock0/form g.non-term-form))
...) ...)
...) ...)
(list (list (lambda () (racket contract-nonterm)) (list (list (lambda () (racket c.contract-nonterm))
(lambda () (racketblock0 contract-expr))) (lambda () (racketblock0 c.contract-expr)))
...) ...)
(lambda () (list desc ...))))))] (lambda () (list desc ...)))))]))
[(fm #:id defined-id #:literals (lit ...) [spec spec1 ...]
([non-term-id non-term-form ...] ...)
#:contracts ([contract-nonterm contract-expr] ...)
desc ...)
(syntax/loc stx
(fm #:kind #f #:id defined-id #:literals (lit ...) [spec spec1 ...]
([non-term-id non-term-form ...] ...)
#:contracts ([contract-nonterm contract-expr] ...)
desc ...))]
[(fm #:id defined-id #:literals (lit ...) [spec spec1 ...]
([non-term-id non-term-form ...] ...)
desc ...)
(syntax/loc stx
(fm #:id defined-id #:literals (lit ...) [spec spec1 ...]
([non-term-id non-term-form ...] ...)
#:contracts ()
desc ...))]
[(fm #:kind kind #:id defined-id #:literals (lit ...) [spec spec1 ...]
([non-term-id non-term-form ...] ...)
desc ...)
(syntax/loc stx
(fm #:kind kind #:id defined-id #:literals (lit ...) [spec spec1 ...]
([non-term-id non-term-form ...] ...)
#:contracts ()
desc ...))]
[(fm #:id id [spec spec1 ...] ([non-term-id non-term-form ...] ...)
desc ...)
(syntax/loc stx
(fm #:kind #f #:id id #:literals () [spec spec1 ...]
([non-term-id non-term-form ...] ...)
#:contracts ()
desc ...))]
[(fm #:kind kind #:literals lits [(spec-id . spec-rest) spec1 ...]
([non-term-id non-term-form ...] ...)
desc ...)
(with-syntax ([(_ _ _ _ _ [spec . _] . _) stx])
(syntax/loc stx
(fm #:kind kind #:id spec-id #:literals lits [spec spec1 ...]
([non-term-id non-term-form ...] ...)
desc ...)))]
[(fm #:literals lits [(spec-id . spec-rest) spec1 ...]
([non-term-id non-term-form ...] ...)
desc ...)
(with-syntax ([(_ _ _ [spec . _] . _) stx])
(syntax/loc stx
(fm #:kind #f #:id spec-id #:literals lits [spec spec1 ...]
([non-term-id non-term-form ...] ...)
desc ...)))]
[(fm #:kind kind [spec spec1 ...] ([non-term-id non-term-form ...] ...) desc ...)
(syntax/loc stx
(fm #:kind kind #:literals () [spec spec1 ...] ([non-term-id non-term-form ...] ...)
desc ...))]
[(fm [spec spec1 ...] ([non-term-id non-term-form ...] ...) desc ...)
(syntax/loc stx
(fm #:kind #f #:literals () [spec spec1 ...] ([non-term-id non-term-form ...] ...)
desc ...))]))
(define-syntax (defform* stx) (define-syntax (defform* stx)
(syntax-case stx () (syntax-parse stx
[(_ #:kind kind #:id id #:literals lits [spec ...] desc ...) [(_ k:kind-kw d:id-kw l:literals-kw [spec ...] desc ...)
(syntax/loc stx (syntax/loc stx
(defform*/subs #:kind kind #:id id #:literals lits [spec ...] () desc ...))] (defform*/subs #:kind k.kind
[(_ #:id id #:literals lits [spec ...] desc ...) #:id [d.defined-id d.defined-id-expr]
(syntax/loc stx #:literals (l.lit ...)
(defform*/subs #:id id #:literals lits [spec ...] () desc ...))] [spec ...] () desc ...))]))
[(_ #:kind kind #:literals lits [spec ...] desc ...)
(syntax/loc stx
(defform*/subs #:kind kind #:literals lits [spec ...] () desc ...))]
[(_ #:literals lits [spec ...] desc ...)
(syntax/loc stx
(defform*/subs #:literals lits [spec ...] () desc ...))]
[(_ #:kind kind #:id id [spec ...] desc ...)
(syntax/loc stx
(defform*/subs #:kind kind #:id id [spec ...] () desc ...))]
[(_ #:id id [spec ...] desc ...)
(syntax/loc stx
(defform*/subs #:id id [spec ...] () desc ...))]
[(_ #:kind kind [spec ...] desc ...)
(syntax/loc stx
(defform*/subs #:kind kind [spec ...] () desc ...))]
[(_ [spec ...] desc ...)
(syntax/loc stx
(defform*/subs [spec ...] () desc ...))]))
(define-syntax (defform stx) (define-syntax (defform stx)
(syntax-case stx () (syntax-parse stx
[(_ #:kind kind #:id id #:literals (lit ...) spec desc ...) [(_ k:kind-kw d:id-kw l:literals-kw spec desc ...)
(syntax/loc stx (syntax/loc stx
(defform*/subs #:kind kind #:id id #:literals (lit ...) [spec] () desc ...))] (defform*/subs #:kind k.kind
[(_ #:id id #:literals (lit ...) spec desc ...) #:id [d.defined-id d.defined-id-expr]
(syntax/loc stx #:literals (l.lit ...)
(defform*/subs #:id id #:literals (lit ...) [spec] () desc ...))] [spec] () desc ...))]))
[(_ #:kind kind #:id id spec desc ...)
(syntax/loc stx
(defform*/subs #:kind kind #:id id #:literals () [spec] () desc ...))]
[(_ #:id id spec desc ...)
(syntax/loc stx
(defform*/subs #:id id #:literals () [spec] () desc ...))]
[(_ #:literals (lit ...) spec desc ...)
(syntax/loc stx
(defform*/subs #:literals (lit ...) [spec] () desc ...))]
[(_ #:kind kind #:literals (lit ...) spec desc ...)
(syntax/loc stx
(defform*/subs #:kind kind #:literals (lit ...) [spec] () desc ...))]
[(_ #:kind kind spec desc ...)
(syntax/loc stx
(defform*/subs #:kind kind [spec] () desc ...))]
[(_ spec desc ...)
(syntax/loc stx
(defform*/subs [spec] () desc ...))]))
(define-syntax (defform/subs stx) (define-syntax (defform/subs stx)
(syntax-case stx () (syntax-parse stx
[(_ #:kind kind #:id id #:literals lits spec subs desc ...) [(_ k:kind-kw d:id-kw l:literals-kw spec subs desc ...)
(syntax/loc stx (syntax/loc stx
(defform*/subs #:kind kind #:id id #:literals lits [spec] subs desc ...))] (defform*/subs #:kind k.kind
[(_ #:id id #:literals lits spec subs desc ...) #:id [d.defined-id d.defined-id-expr]
(syntax/loc stx #:literals (l.lit ...)
(defform*/subs #:id id #:literals lits [spec] subs desc ...))] [spec] subs desc ...))]))
[(_ #:kind kind #:id id spec subs desc ...)
(syntax/loc stx
(defform*/subs #:kind kind #:id id #:literals () [spec] subs desc ...))]
[(_ #:id id spec subs desc ...)
(syntax/loc stx
(defform*/subs #:id id #:literals () [spec] subs desc ...))]
[(_ #:kind kind #:literals lits spec subs desc ...)
(syntax/loc stx
(defform*/subs #:kind kind #:literals lits [spec] subs desc ...))]
[(_ #:literals lits spec subs desc ...)
(syntax/loc stx
(defform*/subs #:literals lits [spec] subs desc ...))]
[(_ #:kind kind spec subs desc ...)
(syntax/loc stx
(defform*/subs #:kind kind [spec] subs desc ...))]
[(_ spec subs desc ...)
(syntax/loc stx
(defform*/subs [spec] subs desc ...))]))
(define-syntax (defform/none stx) (define-syntax (defform/none stx)
(syntax-case stx () (syntax-parse stx
[(_ #:kind kind #:literals (lit ...) spec #:contracts ([contract-id contract-expr] ...) desc ...) [(_ k:kind-kw l:literals-kw spec c:contracts-kw desc ...)
(begin (syntax/loc stx
(for-each (lambda (id) (with-togetherable-racket-variables
(unless (identifier? id) (l.lit ...)
(raise-syntax-error #f
"expected an identifier for a literal"
stx
id)))
(syntax->list #'(lit ...)))
#'(with-togetherable-racket-variables
(lit ...)
([form/none spec]) ([form/none spec])
(*defforms kind #f (*defforms k.kind #f
'(spec) (list (lambda (ignored) (racketblock0/form spec))) '(spec) (list (lambda (ignored) (racketblock0/form spec)))
null null null null
(list (list (lambda () (racket contract-id)) (list (list (lambda () (racket c.contract-id))
(lambda () (racketblock0 contract-expr))) (lambda () (racketblock0 c.contract-expr)))
...) ...)
(lambda () (list desc ...)))))] (lambda () (list desc ...)))))]))
[(fm #:literals (lit ...) spec #:contracts ([contract-id contract-expr] ...) desc ...)
(syntax/loc stx
(fm #:kind #f #:literals (lit ...) spec #:contracts ([contract-id contract-expr] ...) desc ...))]
[(fm #:kind kind #:literals (lit ...) spec desc ...)
(syntax/loc stx
(fm #:kind kind #:literals (lit ...) spec #:contracts () desc ...))]
[(fm #:literals (lit ...) spec desc ...)
(syntax/loc stx
(fm #:literals (lit ...) spec #:contracts () desc ...))]
[(fm #:kind kind spec desc ...)
(syntax/loc stx
(fm #:kind kind #:literals () spec desc ...))]
[(fm spec desc ...)
(syntax/loc stx
(fm #:literals () spec desc ...))]))
(define-syntax (defidform/inline stx) (define-syntax (defidform/inline stx)
(syntax-case stx (unsyntax) (syntax-case stx (unsyntax)
@ -254,21 +153,18 @@
#'(defform-site id-expr)])) #'(defform-site id-expr)]))
(define-syntax (defidform stx) (define-syntax (defidform stx)
(syntax-case stx () (syntax-parse stx
[(_ #:kind kind spec-id desc ...) [(_ k:kind-kw spec-id desc ...)
#'(with-togetherable-racket-variables #'(with-togetherable-racket-variables
() ()
() ()
(*defforms kind (quote-syntax/loc spec-id) (*defforms k.kind (quote-syntax/loc spec-id)
'(spec-id) '(spec-id)
(list (lambda (x) (make-omitable-paragraph (list x)))) (list (lambda (x) (make-omitable-paragraph (list x))))
null null
null null
null null
(lambda () (list desc ...))))] (lambda () (list desc ...))))]))
[(fm spec-id desc ...)
(syntax/loc stx
(fm #:kind #f spec-id desc ...))]))
(define (into-blockquote s) (define (into-blockquote s)
(make-blockquote "leftindent" (make-blockquote "leftindent"
@ -284,46 +180,40 @@
(syntax-case stx () (syntax-case stx ()
[(_ . rest) #'(into-blockquote (defform* . rest))])) [(_ . rest) #'(into-blockquote (defform* . rest))]))
(define-syntax spec?form/subs (define-syntax (spec?form/subs stx)
(syntax-rules () (syntax-parse stx
[(_ has-kw? #:literals (lit ...) spec ([non-term-id non-term-form ...] ...) [(_ has-kw? l:literals-kw spec g:grammar
#:contracts ([contract-nonterm contract-expr] ...) c:contracts-kw
desc ...) desc ...)
(syntax/loc stx
(with-racket-variables (with-racket-variables
(lit ...) (l.lit ...)
([form/maybe (has-kw? spec)] ([form/maybe (has-kw? spec)]
[non-term (non-term-id non-term-form ...)] ...) [non-term (g.non-term-id g.non-term-form ...)] ...)
(*specsubform 'spec '(lit ...) (lambda () (racketblock0/form spec)) (*specsubform 'spec '(l.lit ...) (lambda () (racketblock0/form spec))
'((non-term-id non-term-form ...) ...) '((g.non-term-id g.non-term-form ...) ...)
(list (list (lambda () (racket non-term-id)) (list (list (lambda () (racket g.non-term-id))
(lambda () (racketblock0/form non-term-form)) (lambda () (racketblock0/form g.non-term-form))
...) ...)
...) ...)
(list (list (lambda () (racket contract-nonterm)) (list (list (lambda () (racket c.contract-nonterm))
(lambda () (racketblock0 contract-expr))) (lambda () (racketblock0 c.contract-expr)))
...) ...)
(lambda () (list desc ...))))] (lambda () (list desc ...)))))]))
[(_ has-kw? #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
desc ...)
(spec?form/subs has-kw? #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
#:contracts ()
desc ...)]))
(define-syntax specsubform (define-syntax (specsubform stx)
(syntax-rules () (syntax-parse stx
[(_ #:literals (lit ...) spec desc ...) [(_ l:literals-kw spec desc ...)
(spec?form/subs #f #:literals (lit ...) spec () desc ...)] (syntax/loc stx
[(_ spec desc ...) (spec?form/subs #f #:literals (l.lit ...) spec () desc ...))]))
(specsubform #:literals () spec desc ...)]))
(define-syntax specsubform/subs (define-syntax (specsubform/subs stx)
(syntax-rules () (syntax-parse stx
[(_ #:literals (lit ...) spec ([non-term-id non-term-form ...] ...) [(_ l:literals-kw spec g:grammar desc ...)
desc ...) (syntax/loc stx
(spec?form/subs #f #:literals (lit ...) spec ([non-term-id non-term-form ...] ...) (spec?form/subs #f #:literals (l.lit ...) spec
desc ...)] ([g.non-term-id g.non-term-form ...] ...)
[(_ spec subs desc ...) desc ...))]))
(specsubform/subs #:literals () spec subs desc ...)]))
(define-syntax-rule (specspecsubform spec desc ...) (define-syntax-rule (specspecsubform spec desc ...)
(make-blockquote "leftindent" (list (specsubform spec desc ...)))) (make-blockquote "leftindent" (list (specsubform spec desc ...))))
@ -338,15 +228,13 @@
[(_ spec desc ...) [(_ spec desc ...)
(specform #:literals () spec desc ...)])) (specform #:literals () spec desc ...)]))
(define-syntax specform/subs (define-syntax (specform/subs stx)
(syntax-rules () (syntax-parse stx
[(_ #:literals (lit ...) spec ([non-term-id non-term-form ...] ...) [(_ l:literals-kw spec g:grammar
desc ...) desc ...)
(spec?form/subs #t #:literals (lit ...) spec ([non-term-id non-term-form ...] ...) (syntax/loc stx
desc ...)] (spec?form/subs #t #:literals (l.lit ...) spec ([g.non-term-id g.non-term-form ...] ...)
[(_ spec ([non-term-id non-term-form ...] ...) desc ...) desc ...))]))
(specform/subs #:literals () spec ([non-term-id non-term-form ...] ...)
desc ...)]))
(define-syntax-rule (specsubform/inline spec desc ...) (define-syntax-rule (specsubform/inline spec desc ...)
(with-racket-variables (with-racket-variables

114
collects/scribble/private/manual-proc.rkt
View File

@ -17,7 +17,8 @@
"on-demand.rkt" "on-demand.rkt"
scheme/string scheme/string
scheme/list scheme/list
(for-syntax racket/base) (for-syntax racket/base
syntax/parse)
(for-label racket/base (for-label racket/base
racket/contract racket/contract
racket/class)) racket/class))
@ -78,11 +79,14 @@
(define-syntax (extract-proc-id stx) (define-syntax (extract-proc-id stx)
(syntax-case stx () (syntax-case stx ()
[(_ id) [(_ k e id)
(identifier? #'id) (identifier? #'id)
#`(quote-syntax/loc id)] (if (and (syntax-e #'k)
[(_ (proto arg ...)) (free-identifier=? #'k #'id))
#'(extract-proc-id proto)] #'e
#`(quote-syntax/loc id))]
[(_ k e (proto arg ...))
#'(extract-proc-id k e proto)]
[(_ thing) (raise-syntax-error 'defproc "bad prototype" #'thing)])) [(_ thing) (raise-syntax-error 'defproc "bad prototype" #'thing)]))
(define-syntax (arg-contracts stx) (define-syntax (arg-contracts stx)
@ -113,39 +117,62 @@
"expected a result contract, found a string" #'c) "expected a result contract, found a string" #'c)
#'(racketblock0 c))])) #'(racketblock0 c))]))
(define-syntax defproc (begin-for-syntax
(syntax-rules () (define-splicing-syntax-class kind-kw
[(_ #:kind kind (id arg ...) result desc ...) #:description "#:kind keyword"
(defproc* #:kind kind [[(id arg ...) result]] desc ...)] (pattern (~optional (~seq #:kind kind)
[(_ (id arg ...) result desc ...) #:defaults ([kind #'#f]))))
(defproc* [[(id arg ...) result]] desc ...)]))
(define-syntax defproc* (define-syntax-class id-or-false
(syntax-rules () (pattern i:id)
[(_ #:kind kind #:mode m #:within cl [[proto result] ...] desc ...) (pattern #f #:with i #'#f))
(define-splicing-syntax-class id-kw
#:description "#:id keyword"
(pattern (~optional (~seq #:id [key:id-or-false expr])
#:defaults ([key #'#f]
[expr #'#f]))))
(define-splicing-syntax-class mode-kw
#:description "#:mode keyword"
(pattern (~optional (~seq #:mode m:id)
#:defaults ([m #'procedure]))))
(define-splicing-syntax-class within-kw
#:description "#:within keyword"
(pattern (~optional (~seq #:within cl:id)
#:defaults ([cl #'#f]))))
)
(define-syntax (defproc stx)
(syntax-parse stx
[(_ kind:kind-kw i:id-kw (id arg ...) result desc ...)
(syntax/loc stx
(defproc* #:kind kind.kind #:id [i.key i.expr] [[(id arg ...) result]] desc ...))]))
(define-syntax (defproc* stx)
(syntax-parse stx
[(_ kind:kind-kw d:id-kw mode:mode-kw within:within-kw [[proto result] ...] desc ...)
(syntax/loc stx
(with-togetherable-racket-variables (with-togetherable-racket-variables
() ()
([proc proto] ...) ([proc proto] ...)
(*defproc kind (let ([alt-id d.expr])
'm (quote-syntax/loc cl) (*defproc kind.kind
(list (extract-proc-id proto) ...) 'mode.m (quote-syntax/loc within.cl)
(list (extract-proc-id d.key alt-id proto) ...)
'd.key
'[proto ...] '[proto ...]
(list (arg-contracts proto) ...) (list (arg-contracts proto) ...)
(list (arg-defaults proto) ...) (list (arg-defaults proto) ...)
(list (lambda () (result-contract result)) ...) (list (lambda () (result-contract result)) ...)
(lambda () (list desc ...))))] (lambda () (list desc ...))))))]))
[(_ #:mode m #:within cl [[proto result] ...] desc ...)
(defproc* #:kind #f #:mode m #:within cl [[proto result] ...] desc ...)]
[(_ #:kind kind [[proto result] ...] desc ...)
(defproc* #:kind kind #:mode procedure #:within #f [[proto result] ...] desc ...)]
[(_ [[proto result] ...] desc ...)
(defproc* #:kind #f #:mode procedure #:within #f [[proto result] ...] desc ...)]))
(define-struct arg (define-struct arg
(special? kw id optional? starts-optional? ends-optional? num-closers)) (special? kw id optional? starts-optional? ends-optional? num-closers))
(define (*defproc kind mode within-id (define (*defproc kind mode within-id
stx-ids prototypes arg-contractss arg-valss result-contracts stx-ids sym prototypes arg-contractss arg-valss result-contracts
content-thunk) content-thunk)
(define max-proto-width (current-display-width)) (define max-proto-width (current-display-width))
(define ((arg->elem show-opt-start?) arg) (define ((arg->elem show-opt-start?) arg)
@ -240,9 +267,14 @@
(arg-id (cadr s))))) (arg-id (cadr s)))))
(+ 1 (string-length (symbol->string (arg-id (cadr s))))) (+ 1 (string-length (symbol->string (arg-id (cadr s)))))
0))))))))) 0)))))))))
(define (extract-id p) (define (extract-id p stx-id)
(let loop ([p p]) (let loop ([p p])
(if (symbol? (car p)) (car p) (loop (car p))))) (if (symbol? (car p))
(let ([s (car p)])
(if (eq? s sym)
(syntax-e stx-id)
(car p)))
(loop (car p)))))
(define (do-one stx-id prototype args arg-contracts arg-vals result-contract (define (do-one stx-id prototype args arg-contracts arg-vals result-contract
first? add-background-label?) first? add-background-label?)
(let ([names (remq* '(... ...+) (map arg-id args))]) (let ([names (remq* '(... ...+) (map arg-id args))])
@ -262,7 +294,7 @@
(list (racket send) spacer (list (racket send) spacer
(name-this-object (syntax-e within-id)) spacer (name-this-object (syntax-e within-id)) spacer
(if first? (if first?
(let* ([mname (extract-id prototype)] (let* ([mname (extract-id prototype stx-id)]
[target-maker (id-to-target-maker within-id #f)] [target-maker (id-to-target-maker within-id #f)]
[content (list (*method mname within-id))]) [content (list (*method mname within-id))])
(if target-maker (if target-maker
@ -285,11 +317,11 @@
libs mname ctag))))) libs mname ctag)))))
tag)))) tag))))
(car content))) (car content)))
(*method (extract-id prototype) within-id))))] (*method (extract-id prototype stx-id) within-id))))]
[first? [first?
(define the-id (extract-id prototype stx-id))
(let ([target-maker (id-to-target-maker stx-id #t)] (let ([target-maker (id-to-target-maker stx-id #t)]
[content (list (definition-site (extract-id prototype) [content (list (definition-site the-id stx-id #f))])
stx-id #f))])
(if target-maker (if target-maker
(target-maker (target-maker
content content
@ -298,21 +330,20 @@
#f #f
(list (make-index-element (list (make-index-element
#f content tag #f content tag
(list (datum-intern-literal (symbol->string (extract-id prototype)))) (list (datum-intern-literal (symbol->string the-id)))
content content
(with-exporting-libraries (with-exporting-libraries
(lambda (libs) (lambda (libs)
(make-procedure-index-desc (extract-id prototype) (make-procedure-index-desc the-id libs)))))
libs)))))
tag))) tag)))
(car content)))] (car content)))]
[else [else
(define the-id (extract-id prototype stx-id))
(annote-exporting-library (annote-exporting-library
(let ([sig (current-signature)]) (let ([sig (current-signature)])
(if sig (if sig
(*sig-elem (sig-id sig) (extract-id prototype)) (*sig-elem (sig-id sig) the-id)
(to-element (make-just-context (extract-id prototype) (to-element (make-just-context the-id stx-id)))))]))
stx-id)))))]))
(define p-depth (prototype-depth prototype)) (define p-depth (prototype-depth prototype))
(define flat-size (+ (prototype-size args + + #f) (define flat-size (+ (prototype-size args + + #f)
p-depth p-depth
@ -495,12 +526,13 @@
(append-map (append-map
do-one do-one
stx-ids prototypes all-args arg-contractss arg-valss result-contracts stx-ids prototypes all-args arg-contractss arg-valss result-contracts
(let loop ([ps prototypes] [accum null]) (let loop ([ps prototypes] [stx-ids stx-ids] [accum null])
(cond [(null? ps) null] (cond [(null? ps) null]
[(ormap (lambda (a) (eq? (extract-id (car ps)) a)) accum) [(ormap (lambda (a) (eq? (extract-id (car ps) (car stx-ids)) a)) accum)
(cons #f (loop (cdr ps) accum))] (cons #f (loop (cdr ps) (cdr stx-ids) accum))]
[else (cons #t (loop (cdr ps) [else (cons #t (loop (cdr ps)
(cons (extract-id (car ps)) accum)))])) (cdr stx-ids)
(cons (extract-id (car ps) (car stx-ids)) accum)))]))
(for/list ([p (in-list prototypes)] (for/list ([p (in-list prototypes)]
[i (in-naturals)]) [i (in-naturals)])
(= i 0)))))) (= i 0))))))

15
collects/scribblings/scribble/manual.scrbl
View File

@ -671,7 +671,7 @@ sub-sections.}
@; ------------------------------------------------------------------------ @; ------------------------------------------------------------------------
@section[#:tag "doc-forms"]{Documenting Forms, Functions, Structure Types, and Values} @section[#:tag "doc-forms"]{Documenting Forms, Functions, Structure Types, and Values}
@defform/subs[(defproc maybe-kind prototype @defform/subs[(defproc maybe-kind maybe-id prototype
result-contract-expr-datum result-contract-expr-datum
pre-flow ...) pre-flow ...)
([prototype (id arg-spec ...) ([prototype (id arg-spec ...)
@ -684,6 +684,8 @@ sub-sections.}
ellipses+] ellipses+]
[maybe-kind code:blank [maybe-kind code:blank
(code:line #:kind kind-string-expr)] (code:line #:kind kind-string-expr)]
[maybe-id code:blank
(code:line #:id [src-id dest-id-expr])]
[ellipses @#,lit-ellipses] [ellipses @#,lit-ellipses]
[ellipses+ @#,lit-ellipses+])]{ [ellipses+ @#,lit-ellipses+])]{
@ -747,10 +749,17 @@ An optional @racket[#:kind] specification chooses the decorative
label, which defaults to @racket["procedure"]. A @racket[#f] label, which defaults to @racket["procedure"]. A @racket[#f]
result for @racket[kind-string-expr] uses the default, otherwise result for @racket[kind-string-expr] uses the default, otherwise
@racket[kind-string-expr] should produce a string. An alternate @racket[kind-string-expr] should produce a string. An alternate
label should be all lowercase.} label should be all lowercase.
If @racket[#:id [src-id dest-id-expr]] is supplied, then
@racket[src-id] is the identifier as it appears in the
@racket[prototype] (to be replaced by a defining instance), and
@racket[dest-id-expr] produces the identifier to be documented in
place of @racket[src-id]. This split between @racket[src-id] and
@racket[dest-id-expr] roles is useful for functional abstraction of
@racket[defproc].}
@defform[(defproc* maybe-kind @defform[(defproc* maybe-kind maybe-id
([prototype ([prototype
result-contract-expr-datum] ...) result-contract-expr-datum] ...)
pre-flow ...)]{ pre-flow ...)]{