commit ef13a0dbcc9955d6e9e4eb80b72908862b640e4f
parent 0a11f1f1ee28d8a208cbe00fa3d5bda35b3dfa5f
Author: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 5 Jun 2007 06:44:39 +0000
reference-manual work
svn: r6480
original commit: eeaa856ff139c871299f9452402733cd7bf18269
Diffstat:
3 files changed, 62 insertions(+), 43 deletions(-)
diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss
@@ -137,12 +137,14 @@
;; ----------------------------------------
- (provide defproc defproc* defstruct defthing defform defform/none
+ (provide defproc defproc* defstruct defthing defform defform* defform/none
specsubform specsubform/inline
- var svar void-const)
+ var svar void-const undefined-const)
- (define (void-const)
- (schemefont "#<void>"))
+ (define void-const
+ (schemeresultfont "#<void>"))
+ (define undefined-const
+ (schemeresultfont "#<undefined>"))
(define dots0
(make-element #f (list "...")))
@@ -161,9 +163,9 @@
(syntax-rules ()
[(_ name fields desc ...)
(*defstruct 'name 'fields (lambda () (list desc ...)))]))
- (define-syntax (defform stx)
+ (define-syntax (defform* stx)
(syntax-case stx ()
- [(_ spec desc ...)
+ [(_ [spec spec1 ...] desc ...)
(with-syntax ([new-spec
(syntax-case #'spec ()
[(name . rest)
@@ -174,11 +176,17 @@
#'name)
#'rest)
#'spec)])])
- #'(*defform #t 'spec (lambda (x) (schemeblock0 new-spec)) (lambda () (list desc ...))))]))
+ #'(*defforms #t '(spec spec1 ...)
+ (list (lambda (x) (schemeblock0 new-spec))
+ (lambda (ignored) (schemeblock0 spec1)) ...)
+ (lambda () (list desc ...))))]))
+ (define-syntax (defform stx)
+ (syntax-case stx ()
+ [(_ spec desc ...) #'(defform* [spec] desc ...)]))
(define-syntax (defform/none stx)
(syntax-case stx ()
[(_ spec desc ...)
- #'(*defform #f 'spec (lambda (ignored) (schemeblock0 spec)) (lambda () (list desc ...)))]))
+ #'(*defforms #f '(spec) (list (lambda (ignored) (schemeblock0 spec))) (lambda () (list desc ...)))]))
(define-syntax specsubform
(syntax-rules ()
[(_ spec desc ...)
@@ -383,35 +391,42 @@
(define (meta-symbol? s) (memq s '(... ...+ ?)))
- (define (*defform kw? form form-proc content-thunk)
+ (define (*defforms kw? forms form-procs content-thunk)
(parameterize ([current-variable-list
- (let loop ([form (if kw? (cdr form) form)])
- (cond
- [(symbol? form) (if (meta-symbol? form)
- null
- (list form))]
- [(pair? form) (append (loop (car form))
- (loop (cdr form)))]
- [else null]))])
+ (apply
+ append
+ (map (lambda (form)
+ (let loop ([form (if kw? (cdr form) form)])
+ (cond
+ [(symbol? form) (if (meta-symbol? form)
+ null
+ (list form))]
+ [(pair? form) (append (loop (car form))
+ (loop (cdr form)))]
+ [else null])))
+ forms))])
(make-splice
(cons
(make-table
'boxed
- (list
- (list (make-flow
- (list
- ((or form-proc
- (lambda (x)
- (make-paragraph
- (list
- (to-element
- `(,x
- . ,(cdr form)))))))
- (and kw?
- (make-target-element
- #f
- (list (to-element (car form)))
- (register-scheme-form-definition (car form))))))))))
+ (map (lambda (form form-proc)
+ (list
+ (make-flow
+ (list
+ ((or form-proc
+ (lambda (x)
+ (make-paragraph
+ (list
+ (to-element
+ `(,x
+ . ,(cdr form)))))))
+ (and kw?
+ (eq? form (car forms))
+ (make-target-element
+ #f
+ (list (to-element (car form)))
+ (register-scheme-form-definition (car form)))))))))
+ forms form-procs))
(content-thunk)))))
(define (*specsubform form form-thunk content-thunk)
diff --git a/collects/scribble/scheme.ss b/collects/scribble/scheme.ss
@@ -28,19 +28,19 @@
(define opt-color "schemeopt")
(define current-keyword-list
- (make-parameter '(define let let* letrec require provide let-values
- lambda new send if cond begin else and or
+ (make-parameter '(define require provide
+ new send if cond begin else and or
define-syntax syntax-rules define-struct
quote quasiquote unquote unquote-splicing
syntax quasisyntax unsyntax unsyntax-splicing
- for/fold for/list for*/list for for/and for/or for* for*/or for*/and for*/fold
- for-values for*/list-values for/first for/last
set!)))
(define current-variable-list
(make-parameter null))
(define defined-names (make-hash-table))
+ (define-struct (sized-element element) (length))
+
(define (typeset c multi-line? prefix1 prefix color?)
(let* ([c (syntax-ize c 0)]
[content null]
@@ -63,7 +63,10 @@
(define out
(case-lambda
[(v cls)
- (out v cls (if (string? v) (string-length v) 1))]
+ (out v cls (cond
+ [(string? v) (string-length v)]
+ [(sized-element? v) (sized-element-length v)]
+ [else 1]))]
[(v cls len)
(unless (equal? v "")
(if (equal? v "\n")
@@ -125,12 +128,13 @@
(datum->syntax-object
a
(let ([val? (positive? quote-depth)])
- (make-element
+ (make-sized-element
(if val? value-color #f)
(list
(make-element (if val? value-color paren-color) '(". "))
(typeset a #f "" "" (not val?))
- (make-element (if val? value-color paren-color) '(" .")))))
+ (make-element (if val? value-color paren-color) '(" .")))
+ (+ (syntax-span a) 4)))
(list (syntax-source a)
(syntax-line a)
(- (syntax-column a) 2)
@@ -327,7 +331,7 @@
(out (if (and (identifier? c)
color?
(quote-depth . <= . 0)
- (not (or it? is-kw? is-var?)))
+ (not (or it? is-var?)))
(make-delayed-element
(lambda (renderer sec ht)
(let* ([vtag (register-scheme-definition (syntax-e c))]
diff --git a/collects/scribblings/scribble/manual.scrbl b/collects/scribblings/scribble/manual.scrbl
@@ -307,9 +307,9 @@ for the index entry.}
@defthing[PLaneT string?]{@scheme["PLaneT"] (to help make sure you get
the letters in the right case).}
-@defproc[(void-const) any/c]{Returns @scheme["void"], as opposed to
-@scheme[(scheme void)]---but we may eventually find a clearer way to
-refer to @void-const in prose.}
+@defthing[void-const element?]{Returns an element for @|void-const|.}
+
+@defthing[undefined-const element?]{Returns an element for @|undefined-const|.}
@defproc[(centerline [pre-flow any/c] ...0) table?]{Produces a
centered table with the @scheme[pre-flow] parsed by
