From 4139a7271c7ba7c2b6f34e77a5574e28ff6fcc78 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 17 Feb 2009 01:15:38 +0000 Subject: [PATCH] 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 --- collects/scribble/private/manual-form.ss | 2 +- collects/scribble/private/manual-proc.ss | 11 +- collects/scribble/private/manual-vars.ss | 31 ++++-- collects/scribble/scheme.ss | 124 ++++++++++++--------- collects/scribblings/scribble/manual.scrbl | 16 +-- collects/scribblings/scribble/reader.scrbl | 1 + 6 files changed, 110 insertions(+), 75 deletions(-) diff --git a/collects/scribble/private/manual-form.ss b/collects/scribble/private/manual-form.ss index 8b348a6b..1302b65d 100644 --- 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 index 110aa0fc..22130a06 100644 --- 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 index e5e566af..9d824980 100644 --- 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 index 443af073..0a201e60 100644 --- 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 index 8fb1b956..6b97fcad 100644 --- 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 index 0b4babd0..449b1d97 100644 --- 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[] +