commit 4139a7271c7ba7c2b6f34e77a5574e28ff6fcc78
parent 1617e8d8ae6299ba99cf6d18d41f1a35b9a934e1
Author: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 17 Feb 2009 01:15:38 +0000
Scribble: change handling of argumentd in defproc, etc., to use lexical bidning instead of parameters and symbols; fix some docs
svn: r13688
original commit: 0f18d68649bf7e0caa9e02f2739629129ef644e8
Diffstat:
6 files changed, 110 insertions(+), 75 deletions(-)
diff --git a/collects/scribble/private/manual-form.ss b/collects/scribble/private/manual-form.ss
@@ -153,7 +153,7 @@
(syntax->list #'(lit ...)))
#'(with-togetherable-scheme-variables
(lit ...)
- ([form spec])
+ ([form/none spec])
(*defforms #f
'(spec) (list (lambda (ignored) (schemeblock0/form spec)))
null null
diff --git a/collects/scribble/private/manual-proc.ss b/collects/scribble/private/manual-proc.ss
@@ -143,16 +143,17 @@
#f (list (schemeparenfont "[")
(schemeidfont (keyword->string (arg-kw arg)))
spacer
- (to-element (arg-id arg))
+ (to-element (make-var-id (arg-id arg)))
(schemeparenfont "]")))
(make-element
#f (list (to-element (arg-kw arg))
spacer
- (to-element (arg-id arg)))))
- (to-element (arg-id arg)))]
+ (to-element (make-var-id (arg-id arg))))))
+ (to-element (make-var-id (arg-id arg))))]
[(eq? (arg-id arg) '...+) dots1]
[(eq? (arg-id arg) '...) dots0]
- [else (to-element (arg-id arg))])]
+ [(eq? (arg-id arg) '_...superclass-args...) (to-element (arg-id arg))]
+ [else (to-element (make-var-id (arg-id arg)))])]
[e (if (arg-ends-optional? arg)
(make-element #f (list e "]"))
e)]
@@ -425,7 +426,7 @@
[def-len (if (arg-optional? arg) (block-width arg-val) 0)]
[base-list
(list (to-flow (hspace 2))
- (to-flow (to-element (arg-id arg)))
+ (to-flow (to-element (make-var-id (arg-id arg))))
flow-spacer
(to-flow ":")
flow-spacer
diff --git a/collects/scribble/private/manual-vars.ss b/collects/scribble/private/manual-vars.ss
@@ -15,15 +15,23 @@
(define-struct (box-splice splice) ())
+(begin-for-syntax (define-struct deftogether-tag () #:omit-define-syntaxes))
+
(define-syntax (with-togetherable-scheme-variables stx)
(syntax-case stx ()
[(_ . rest)
- ;; Make it transparent, so deftogether is allowed to pull it apart
- (syntax-property
- (syntax/loc stx
- (with-togetherable-scheme-variables* . rest))
- 'certify-mode
- 'transparent)]))
+ (let ([result (syntax/loc stx
+ (with-togetherable-scheme-variables* . rest))]
+ [ctx (syntax-local-context)])
+ (if (and (pair? ctx) (deftogether-tag? (car ctx)))
+ ;; Make it transparent, so deftogether is allowed to pull it apart
+ (syntax-property result
+ 'certify-mode
+ 'transparent)
+ ;; Otherwise, don't make it transparent, because that
+ ;; removes certificates that will be needed on the `letrec-syntaxes'
+ ;; that we introduce later.
+ result))]))
(define-syntax-rule (with-togetherable-scheme-variables* . rest)
(with-scheme-variables . rest))
@@ -41,6 +49,7 @@
(if (identifier? arg)
(unless (or (eq? (syntax-e arg) '...)
(eq? (syntax-e arg) '...+)
+ (eq? (syntax-e arg) '_...superclass-args...)
(memq (syntax-e arg) lits))
(bound-identifier-mapping-put! ht arg #t))
(syntax-case arg ()
@@ -51,11 +60,12 @@
(identifier? #'arg)
(bound-identifier-mapping-put! ht #'arg #t)])))
(cdr (syntax->list s-exp)))]
- [(form form/maybe non-term)
+ [(form form/none form/maybe non-term)
(let loop ([form (case (syntax-e kind)
[(form) (if (identifier? s-exp)
null
(cdr (syntax-e s-exp)))]
+ [(form/none) s-exp]
[(form/maybe)
(syntax-case s-exp ()
[(#f form) #'form]
@@ -64,6 +74,9 @@
(if (identifier? form)
(unless (or (eq? (syntax-e form) '...)
(eq? (syntax-e form) '...+)
+ (eq? (syntax-e form) 'code:line)
+ (eq? (syntax-e form) 'code:blank)
+ (eq? (syntax-e form) 'code:comment)
(eq? (syntax-e form) '?)
(memq (syntax-e form) lits))
(bound-identifier-mapping-put! ht form #t))
@@ -81,7 +94,7 @@
(syntax->list #'(kind ...))
(syntax->list #'(s-exp ...)))
(with-syntax ([(id ...) (bound-identifier-mapping-map ht (lambda (k v) k))])
- #'(parameterize ([current-variable-list '(id ...)])
+ #'(letrec-syntaxes ([(id) (make-variable-id 'id)] ...)
body)))]))
@@ -112,7 +125,7 @@
(map (lambda (def)
(let ([exp-def (local-expand
def
- 'expression
+ (list (make-deftogether-tag))
(cons
#'with-togetherable-scheme-variables*
(kernel-form-identifier-list)))])
diff --git a/collects/scribble/scheme.ss b/collects/scribble/scheme.ss
@@ -20,9 +20,11 @@
current-variable-list
current-meta-list
+ (struct-out var-id)
(struct-out shaped-parens)
(struct-out just-context)
- (struct-out literal-syntax))
+ (struct-out literal-syntax)
+ (for-syntax make-variable-id))
(define no-color "schemeplain")
(define reader-color "schemereader")
@@ -118,57 +120,63 @@
(make-element style content)))
(define (typeset-atom c out color? quote-depth)
- (let*-values ([(is-var?) (and (identifier? c)
- (memq (syntax-e c) (current-variable-list)))]
- [(s it? sub?)
- (let ([sc (syntax-e c)])
- (let ([s (format "~s" (if (literal-syntax? sc)
- (literal-syntax-stx sc)
- sc))])
- (if (and (symbol? sc)
- ((string-length s) . > . 1)
- (char=? (string-ref s 0) #\_)
- (not (or (identifier-label-binding c)
- is-var?)))
- (values (substring s 1) #t #f)
- (values s #f #f))))])
- (if (or (element? (syntax-e c))
- (delayed-element? (syntax-e c))
- (part-relative-element? (syntax-e c)))
- (out (syntax-e c) #f)
- (out (if (and (identifier? c)
- color?
- (quote-depth . <= . 0)
- (not (or it? is-var?)))
- (if (pair? (identifier-label-binding c))
- (make-id-element c s)
- s)
- (literalize-spaces s))
- (cond
- [(positive? quote-depth) value-color]
- [(let ([v (syntax-e c)])
- (or (number? v)
- (string? v)
- (bytes? v)
- (char? v)
- (regexp? v)
- (byte-regexp? v)
- (boolean? v)))
- value-color]
- [(identifier? c)
- (cond
- [is-var?
- variable-color]
- [(and (identifier? c)
- (memq (syntax-e c) (current-keyword-list)))
- keyword-color]
- [(and (identifier? c)
- (memq (syntax-e c) (current-meta-list)))
- meta-color]
- [it? variable-color]
- [else symbol-color])]
- [else paren-color])
- (string-length s)))))
+ (if (var-id? (syntax-e c))
+ (out (format "~s" (let ([v (var-id-sym (syntax-e c))])
+ (if (syntax? v)
+ (syntax-e v)
+ v)))
+ variable-color)
+ (let*-values ([(is-var?) (and (identifier? c)
+ (memq (syntax-e c) (current-variable-list)))]
+ [(s it? sub?)
+ (let ([sc (syntax-e c)])
+ (let ([s (format "~s" (if (literal-syntax? sc)
+ (literal-syntax-stx sc)
+ sc))])
+ (if (and (symbol? sc)
+ ((string-length s) . > . 1)
+ (char=? (string-ref s 0) #\_)
+ (not (or (identifier-label-binding c)
+ is-var?)))
+ (values (substring s 1) #t #f)
+ (values s #f #f))))])
+ (if (or (element? (syntax-e c))
+ (delayed-element? (syntax-e c))
+ (part-relative-element? (syntax-e c)))
+ (out (syntax-e c) #f)
+ (out (if (and (identifier? c)
+ color?
+ (quote-depth . <= . 0)
+ (not (or it? is-var?)))
+ (if (pair? (identifier-label-binding c))
+ (make-id-element c s)
+ s)
+ (literalize-spaces s))
+ (cond
+ [(positive? quote-depth) value-color]
+ [(let ([v (syntax-e c)])
+ (or (number? v)
+ (string? v)
+ (bytes? v)
+ (char? v)
+ (regexp? v)
+ (byte-regexp? v)
+ (boolean? v)))
+ value-color]
+ [(identifier? c)
+ (cond
+ [is-var?
+ variable-color]
+ [(and (identifier? c)
+ (memq (syntax-e c) (current-keyword-list)))
+ keyword-color]
+ [(and (identifier? c)
+ (memq (syntax-e c) (current-meta-list)))
+ meta-color]
+ [it? variable-color]
+ [else symbol-color])]
+ [else paren-color])
+ (string-length s))))))
(define (gen-typeset c multi-line? prefix1 prefix suffix color?)
(let* ([c (syntax-ize c 0)]
@@ -590,6 +598,8 @@
(define ((to-paragraph/prefix pfx1 pfx sfx) c)
(typeset c #t pfx1 pfx sfx #t))
+ (begin-for-syntax (define-struct variable-id (sym) #:omit-define-syntaxes))
+
(define-syntax (define-code stx)
(syntax-case stx ()
[(_ code typeset-code uncode d->s stx-prop)
@@ -597,6 +607,15 @@
(define-syntax (code stx)
(define (stx->loc-s-expr v)
(cond
+ [(and (identifier? v)
+ (variable-id? (syntax-local-value v (lambda () #f))))
+ `(,#'d->s #f
+ (,#'make-var-id ',(variable-id-sym (syntax-local-value v)))
+ #(code
+ ,(syntax-line v)
+ ,(syntax-column v)
+ ,(syntax-position v)
+ ,(syntax-span v)))]
[(syntax? v)
(let ([mk `(,#'d->s
(quote-syntax ,(datum->syntax v 'defcode))
@@ -666,6 +685,7 @@
(loop (cons (car r) r) (sub1 i)))))
l))))
+ (define-struct var-id (sym))
(define-struct shaped-parens (val shape))
(define-struct just-context (val ctx))
(define-struct literal-syntax (stx))
diff --git a/collects/scribblings/scribble/manual.scrbl b/collects/scribblings/scribble/manual.scrbl
@@ -4,8 +4,8 @@
(for-syntax scheme/base)
(for-label scribble/manual-struct))
-@(define ellipses (scheme ...))
-@(define ellipses+ (scheme ...+))
+@(define lit-ellipses (scheme ...))
+@(define lit-ellipses+ (scheme ...+))
@title[#:tag "manual" #:style 'toc]{Manual Forms}
@@ -357,8 +357,8 @@ sub-sections.}
(keyword arg-id contract-expr-datum default-expr)
ellipses
ellipses+]
- [ellipses #, @ellipses]
- [ellipses+ #, @ellipses+])]{
+ [ellipses #, @lit-ellipses]
+ [ellipses+ #, @lit-ellipses+])]{
Produces a sequence of flow elements (encapsulated in a
@scheme[splice]) to document a procedure named @scheme[id]. Nesting
@@ -393,14 +393,14 @@ Each @scheme[arg-spec] must have one of the following forms:
Like the previous case, but with a default
value.}
-@specsubform[#, @ellipses]{Any number of the preceding argument. This
+@specsubform[#, @lit-ellipses]{Any number of the preceding argument. This
form is normally used at the end, but keyword-based arguments
can sensibly appear afterward. See also the documentation for
- @scheme[append] for a use of @ellipses before the last
+ @scheme[append] for a use of @lit-ellipses before the last
argument.}
-@specsubform[#, @ellipses+]{One or more of the preceding argument
- (normally at the end, like @ellipses).}
+@specsubform[#, @lit-ellipses+]{One or more of the preceding argument
+ (normally at the end, like @lit-ellipses).}
The @scheme[result-contract-expr-datum] is typeset via
@scheme[schemeblock0], and it represents a contract on the procedure's
diff --git a/collects/scribblings/scribble/reader.scrbl b/collects/scribblings/scribble/reader.scrbl
@@ -926,4 +926,5 @@ line counting for the current input-port via @scheme[port-count-lines!].}
@; *** End reader-import section ***
))]))
@with-scribble-read[]
+
