From fbd04f4e97a0201a014b4b36d27e0cf611bff724 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 6 Apr 2010 15:52:36 +0000 Subject: [PATCH] better compiler handling of unused local bindings where the RHS either doesn't obviously produce a single value or is discovered to be unused late in bytecode compilation; initial Scribble support for printing qq-style results svn: r18737 original commit: c5ac9f23ec5d40ef4d81f69d2dde9932dd38fe77 --- collects/scribble/scheme.ss | 472 ++++++++++-------- collects/scribblings/scribble/manual.scrbl | 7 + .../scribble/reader-internals.scrbl | 2 +- collects/scribblings/scribble/scheme.scrbl | 22 +- 4 files changed, 296 insertions(+), 207 deletions(-) diff --git a/collects/scribble/scheme.ss b/collects/scribble/scheme.ss index be6e3453..9e18e736 100644 --- a/collects/scribble/scheme.ss +++ b/collects/scribble/scheme.ss @@ -160,7 +160,23 @@ e)))) (make-element style content))) - (define (typeset-atom c out color? quote-depth) + (define (to-quoted qs qq? quote-depth out color? inc!) + (if (and qq? (zero? quote-depth)) + (begin + (out qs (and color? value-color)) + (inc!) + (add1 quote-depth)) + quote-depth)) + + (define (to-unquoted qq? quote-depth out color? inc!) + (if (or (not qq?) (zero? quote-depth)) + quote-depth + (begin + (out "," (and color? meta-color)) + (inc!) + (to-unquoted qq? (sub1 quote-depth) out color? inc!)))) + + (define (typeset-atom c out color? quote-depth qq?) (if (and (var-id? (syntax-e c)) (zero? quote-depth)) (out (format "~s" (let ([v (var-id-sym (syntax-e c))]) @@ -185,48 +201,56 @@ 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) + (let ([quote-depth (if (and qq? (identifier? c)) + (let ([quote-depth + (if (and (quote-depth . < . 2) + (memq (syntax-e c) '(unquote unquote-splicing))) + (to-unquoted qq? quote-depth out color? void) + quote-depth)]) + (to-quoted "'" qq? quote-depth out color? void)) + quote-depth)]) + (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 - [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)))))) + [(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 omitable (make-style #f '(omitable))) - (define (gen-typeset c multi-line? prefix1 prefix suffix color?) - (let* ([c (syntax-ize c 0)] + (define (gen-typeset c multi-line? prefix1 prefix suffix color? qq?) + (let* ([c (syntax-ize c 0 #:qq? qq?)] [content null] [docs null] [first (syntax-case c (code:line) @@ -234,6 +258,7 @@ [else c])] [init-col (or (syntax-column first) 0)] [src-col init-col] + [inc-src-col (lambda () (set! src-col (add1 src-col)))] [dest-col 0] [highlight? #f] [col-map (make-hash)] @@ -314,7 +339,7 @@ (set! src-col c) (hash-set! next-col-map src-col dest-col)))] [(c init-line!) (advance c init-line! 0)])) - (define (convert-infix c quote-depth) + (define (convert-infix c quote-depth qq?) (let ([l (syntax->list c)]) (and l ((length l) . >= . 3) @@ -340,7 +365,7 @@ (if val? value-color #f) (list (make-element/cache (if val? value-color paren-color) '". ") - (typeset a #f "" "" "" (not val?)) + (typeset a #f "" "" "" (not val?) qq?) (make-element/cache (if val? value-color paren-color) '" .")) (+ (syntax-span a) 4))) (list (syntax-source a) @@ -358,7 +383,7 @@ (cond [(eq? s 'rsquo) "'"] [else s])) - (define (loop init-line! quote-depth) + (define (loop init-line! quote-depth qq?) (lambda (c) (cond [(eq? 'code:blank (syntax-e c)) @@ -394,12 +419,13 @@ (set! src-col s-col) (set! dest-col 0) (out "; " comment-color)) - 0) + 0 + qq?) l))] [(and (pair? (syntax-e c)) (eq? (syntax-e (car (syntax-e c))) 'code:line)) (let ([l (cdr (syntax->list c))]) - (for-each (loop init-line! quote-depth) + (for-each (loop init-line! quote-depth qq?) l))] [(and (pair? (syntax-e c)) (eq? (syntax-e (car (syntax-e c))) 'code:hilite)) @@ -411,59 +437,67 @@ (set! src-col (syntax-column (cadr l))) (hash-set! next-col-map src-col dest-col) (set! highlight? #t) - ((loop init-line! quote-depth) (cadr l)) + ((loop init-line! quote-depth qq?) (cadr l)) (set! highlight? h?) (set! src-col (add1 src-col)))] [(and (pair? (syntax-e c)) (eq? (syntax-e (car (syntax-e c))) 'code:quote)) (advance c init-line!) - (out "(" (if (positive? quote-depth) value-color paren-color)) - (set! src-col (+ src-col 1)) - (hash-set! next-col-map src-col dest-col) - ((loop init-line! quote-depth) - (datum->syntax #'here 'quote (car (syntax-e c)))) - (for-each (loop init-line! (add1 quote-depth)) - (cdr (syntax->list c))) - (out ")" (if (positive? quote-depth) value-color paren-color)) - (set! src-col (+ src-col 1)) - #; - (hash-set! next-col-map src-col dest-col)] + (let ([quote-depth (to-quoted "`" qq? quote-depth out color? inc-src-col)]) + (out "(" (if (positive? quote-depth) value-color paren-color)) + (set! src-col (+ src-col 1)) + (hash-set! next-col-map src-col dest-col) + ((loop init-line! quote-depth qq?) + (datum->syntax #'here 'quote (car (syntax-e c)))) + (for-each (loop init-line! (add1 quote-depth) qq?) + (cdr (syntax->list c))) + (out ")" (if (positive? quote-depth) value-color paren-color)) + (set! src-col (+ src-col 1)) + #; + (hash-set! next-col-map src-col dest-col))] [(and (pair? (syntax-e c)) (memq (syntax-e (car (syntax-e c))) '(quote quasiquote unquote unquote-splicing quasisyntax syntax unsyntax unsyntax-splicing)) (let ([v (syntax->list c)]) - (and v (= 2 (length v))))) + (and v (= 2 (length v)))) + (or (not qq?) + (quote-depth . > . 1) + (not (memq (syntax-e (car (syntax-e c))) + '(unquote unquote-splicing))))) (advance c init-line!) - (let-values ([(str quote-delta) - (case (syntax-e (car (syntax-e c))) - [(quote) (values "'" +inf.0)] - [(unquote) (values "," -1)] - [(unquote-splicing) (values ",@" -1)] - [(quasiquote) (values "`" +1)] - [(syntax) (values "#'" 0)] - [(quasisyntax) (values "#`" 0)] - [(unsyntax) (values "#," 0)] - [(unsyntax-splicing) (values "#,@" 0)])]) - (out str (if (positive? (+ quote-depth quote-delta)) - value-color - reader-color)) - (let ([i (cadr (syntax->list c))]) - (set! src-col (or (syntax-column i) src-col)) - (hash-set! next-col-map src-col dest-col) - ((loop init-line! (+ quote-depth quote-delta)) i)))] + (let ([quote-depth (to-quoted "`" qq? quote-depth out color? inc-src-col)]) + (let-values ([(str quote-delta) + (case (syntax-e (car (syntax-e c))) + [(quote) (values "'" +inf.0)] + [(unquote) (values "," -1)] + [(unquote-splicing) (values ",@" -1)] + [(quasiquote) (values "`" +1)] + [(syntax) (values "#'" 0)] + [(quasisyntax) (values "#`" 0)] + [(unsyntax) (values "#," 0)] + [(unsyntax-splicing) (values "#,@" 0)])]) + (out str (if (positive? (+ quote-depth quote-delta)) + value-color + reader-color)) + (let ([i (cadr (syntax->list c))]) + (set! src-col (or (syntax-column i) src-col)) + (hash-set! next-col-map src-col dest-col) + ((loop init-line! (+ quote-depth quote-delta) qq?) i))))] [(and (pair? (syntax-e c)) - (convert-infix c quote-depth)) + (convert-infix c quote-depth qq?)) => (lambda (converted) - ((loop init-line! quote-depth) converted))] + ((loop init-line! quote-depth qq?) converted))] [(or (pair? (syntax-e c)) (null? (syntax-e c)) (vector? (syntax-e c)) (and (struct? (syntax-e c)) - (prefab-struct-key (syntax-e c)))) + (prefab-struct-key (syntax-e c))) + (struct-proxy? (syntax-e c))) (let* ([sh (or (syntax-property c 'paren-shape) #\()] - [quote-depth (if (and (zero? quote-depth) + [quote-depth (if (and (not qq?) + (zero? quote-depth) (or (vector? (syntax-e c)) (struct? (syntax-e c)))) +inf.0 @@ -474,87 +508,101 @@ opt-color paren-color))]) (advance c init-line!) - (when (vector? (syntax-e c)) - (let ([vec (syntax-e c)]) - (out "#" #;(format "#~a" (vector-length vec)) p-color) - (if (zero? (vector-length vec)) - (set! src-col (+ src-col (- (syntax-span c) 2))) - (set! src-col (+ src-col (- (syntax-column (vector-ref vec 0)) - (syntax-column c) - 1)))))) - (when (struct? (syntax-e c)) - (out "#s" p-color) - (set! src-col (+ src-col 2))) - (out (case sh - [(#\[ #\?) "["] - [(#\{) "{"] - [else "("]) - p-color) - (set! src-col (+ src-col 1)) - (hash-set! next-col-map src-col dest-col) - (let lloop ([l (cond - [(vector? (syntax-e c)) - (vector->short-list (syntax-e c) syntax-e)] - [(struct? (syntax-e c)) - (let ([l (vector->list (struct->vector (syntax-e c)))]) - ;; Need to build key datum, syntax-ize it internally, and - ;; set the overall width to fit right: - (cons (let ([key (syntax-ize (prefab-struct-key (syntax-e c)) - (+ 3 (or (syntax-column c) 0)) - (or (syntax-line c) 1))] - [end (if (pair? (cdr l)) - (and (equal? (syntax-line c) (syntax-line (cadr l))) - (syntax-column (cadr l))) - (and (syntax-column c) - (+ (syntax-column c) (syntax-span c))))]) - (if end - (datum->syntax #f - (syntax-e key) - (vector #f (syntax-line key) - (syntax-column key) - (syntax-position key) - (- end 1 (syntax-column key)))) - end)) - (cdr l)))] - [else c])]) - (cond - [(and (syntax? l) - (pair? (syntax-e l)) - (not (and (memq (syntax-e (car (syntax-e l))) - '(quote unquote syntax unsyntax quasiquote quasiunsyntax)) - (let ([v (syntax->list l)]) - (and v (= 2 (length v))))))) - (lloop (syntax-e l))] - [(or (null? l) - (and (syntax? l) - (null? (syntax-e l)))) - (void)] - [(pair? l) - ((loop init-line! quote-depth) (car l)) - (lloop (cdr l))] - [else - (advance l init-line! -2) - (out ". " (if (positive? quote-depth) value-color paren-color)) - (set! src-col (+ src-col 3)) + (let ([quote-depth (if (struct-proxy? (syntax-e c)) + (to-unquoted qq? quote-depth out color? inc-src-col) + (to-quoted "`" qq? quote-depth out color? inc-src-col))]) + (when (vector? (syntax-e c)) + (let ([vec (syntax-e c)]) + (out "#" #;(format "#~a" (vector-length vec)) p-color) + (if (zero? (vector-length vec)) + (set! src-col (+ src-col (- (syntax-span c) 2))) + (set! src-col (+ src-col (- (syntax-column (vector-ref vec 0)) + (syntax-column c) + 1)))))) + (when (struct? (syntax-e c)) + (out "#s" p-color) + (set! src-col (+ src-col 2))) + (out (case sh + [(#\[ #\?) "["] + [(#\{) "{"] + [else "("]) + p-color) + (set! src-col (+ src-col 1)) (hash-set! next-col-map src-col dest-col) - ((loop init-line! quote-depth) l)])) - (out (case sh - [(#\[ #\?) "]"] - [(#\{) "}"] - [else ")"]) - p-color) - (set! src-col (+ src-col 1)) - #; - (hash-set! next-col-map src-col dest-col))] + (let lloop ([l (cond + [(vector? (syntax-e c)) + (vector->short-list (syntax-e c) syntax-e)] + [(struct? (syntax-e c)) + (let ([l (vector->list (struct->vector (syntax-e c)))]) + ;; Need to build key datum, syntax-ize it internally, and + ;; set the overall width to fit right: + (cons (let ([key (syntax-ize (prefab-struct-key (syntax-e c)) + (+ 3 (or (syntax-column c) 0)) + (or (syntax-line c) 1))] + [end (if (pair? (cdr l)) + (and (equal? (syntax-line c) (syntax-line (cadr l))) + (syntax-column (cadr l))) + (and (syntax-column c) + (+ (syntax-column c) (syntax-span c))))]) + (if end + (datum->syntax #f + (syntax-e key) + (vector #f (syntax-line key) + (syntax-column key) + (syntax-position key) + (- end 1 (syntax-column key)))) + end)) + (cdr l)))] + [(struct-proxy? (syntax-e c)) + (cons + (struct-proxy-name (syntax-e c)) + (struct-proxy-content (syntax-e c)))] + [else c])] + [first-qq? (and qq? (not (struct-proxy? (syntax-e c))))]) + (cond + [(and (syntax? l) + (pair? (syntax-e l)) + (not (and (memq (syntax-e (car (syntax-e l))) + '(quote unquote syntax unsyntax quasiquote quasiunsyntax)) + (let ([v (syntax->list l)]) + (and v (= 2 (length v)))) + (or (not qq?) + (quote-depth . > . 1) + (not (memq (syntax-e (car (syntax-e l))) + '(unquote unquote-splicing))))))) + (lloop (syntax-e l) first-qq?)] + [(or (null? l) + (and (syntax? l) + (null? (syntax-e l)))) + (void)] + [(pair? l) + ((loop init-line! quote-depth first-qq?) (car l)) + (lloop (cdr l) qq?)] + [else + (advance l init-line! -2) + (out ". " (if (positive? quote-depth) value-color paren-color)) + (set! src-col (+ src-col 3)) + (hash-set! next-col-map src-col dest-col) + ((loop init-line! quote-depth first-qq?) l)])) + (out (case sh + [(#\[ #\?) "]"] + [(#\{) "}"] + [else ")"]) + p-color) + (set! src-col (+ src-col 1)) + #; + (hash-set! next-col-map src-col dest-col)))] [(box? (syntax-e c)) (advance c init-line!) - (out "#&" value-color) - (set! src-col (+ src-col 2)) - (hash-set! next-col-map src-col dest-col) - ((loop init-line! +inf.0) (unbox (syntax-e c)))] + (let ([quote-depth (to-quoted "`" qq? quote-depth out color? inc-src-col)]) + (out "#&" value-color) + (set! src-col (+ src-col 2)) + (hash-set! next-col-map src-col dest-col) + ((loop init-line! (if qq? quote-depth +inf.0) qq?) (unbox (syntax-e c))))] [(hash? (syntax-e c)) (advance c init-line!) - (let ([equal-table? (not (hash-eq? (syntax-e c)))]) + (let ([equal-table? (not (hash-eq? (syntax-e c)))] + [quote-depth (to-quoted "`" qq? quote-depth out color? inc-src-col)]) (out (if equal-table? "#hash" "#hasheq") @@ -563,7 +611,7 @@ [orig-col src-col]) (set! src-col (+ src-col delta)) (hash-set! next-col-map src-col dest-col) - ((loop init-line! +inf.0) + ((loop init-line! (if qq? quote-depth +inf.0) qq?) (syntax-ize (hash-map (syntax-e c) cons) (+ (syntax-column c) delta))) (set! src-col (+ orig-col (syntax-span c)))))] @@ -582,17 +630,17 @@ value-color paren-color)) (set! src-col (+ src-col 3)) - ((loop init-line! quote-depth) (graph-defn-r (syntax-e c))))] + ((loop init-line! quote-depth qq?) (graph-defn-r (syntax-e c))))] [else (advance c init-line!) - (typeset-atom c out color? quote-depth) + (typeset-atom c out color? quote-depth qq?) (set! src-col (+ src-col (or (syntax-span c) 1))) #; (hash-set! next-col-map src-col dest-col)]))) (out prefix1 #f) (set! dest-col 0) (hash-set! next-col-map init-col dest-col) - ((loop (lambda () (set! src-col init-col) (set! dest-col 0)) 0) c) + ((loop (lambda () (set! src-col init-col) (set! dest-col 0)) 0 qq?) c) (if (list? suffix) (map (lambda (sfx) (finish-line!) @@ -607,8 +655,8 @@ (make-table block-color (map list (reverse docs)))) (make-sized-element #f (reverse content) dest-col)))) - (define (typeset c multi-line? prefix1 prefix suffix color?) - (let* ([c (syntax-ize c 0)] + (define (typeset c multi-line? prefix1 prefix suffix color? qq?) + (let* ([c (syntax-ize c 0 #:qq? qq?)] [s (syntax-e c)]) (if (or multi-line? (eq? 'code:blank s) @@ -620,7 +668,7 @@ (hash? s) (graph-defn? s) (graph-reference? s)) - (gen-typeset c multi-line? prefix1 prefix suffix color?) + (gen-typeset c multi-line? prefix1 prefix suffix color? qq?) (typeset-atom c (letrec ([mk (case-lambda @@ -632,19 +680,19 @@ (make-element/cache (and color? color) elem) (make-sized-element (and color? color) elem len))])]) mk) - color? 0)))) + color? 0 qq?)))) - (define (to-element c) - (typeset c #f "" "" "" #t)) + (define (to-element c #:qq? [qq? #f]) + (typeset c #f "" "" "" #t qq?)) - (define (to-element/no-color c) - (typeset c #f "" "" "" #f)) + (define (to-element/no-color c #:qq? [qq? #f]) + (typeset c #f "" "" "" #f qq?)) - (define (to-paragraph c) - (typeset c #t "" "" "" #t)) + (define (to-paragraph c #:qq? [qq? #f]) + (typeset c #t "" "" "" #t qq?)) - (define ((to-paragraph/prefix pfx1 pfx sfx) c) - (typeset c #t pfx1 pfx sfx #t)) + (define ((to-paragraph/prefix pfx1 pfx sfx) c #:qq? [qq? #f]) + (typeset c #t pfx1 pfx sfx #t qq?)) (begin-for-syntax (define-struct variable-id (sym) @@ -760,12 +808,13 @@ (define-struct just-context (val ctx)) (define-struct alternate-display (id string)) (define-struct literal-syntax (stx)) + (define-struct struct-proxy (name content)) (define-struct graph-reference (bx)) (define-struct graph-defn (r bx)) - (define (syntax-ize v col [line 1]) - (do-syntax-ize v col line (box #hasheq()) #f)) + (define (syntax-ize v col [line 1] #:qq? [qq? #f]) + (do-syntax-ize v col line (box #hasheq()) #f (and qq? 0))) (define (graph-count ht graph?) (and graph? @@ -773,23 +822,23 @@ (set-box! ht (hash-set (unbox ht) '#%graph-count (add1 n))) n))) - (define (do-syntax-ize v col line ht graph?) + (define (do-syntax-ize v col line ht graph? qq) (cond [((syntax-ize-hook) v col) => (lambda (r) r)] [(shaped-parens? v) - (syntax-property (do-syntax-ize (shaped-parens-val v) col line ht #f) + (syntax-property (do-syntax-ize (shaped-parens-val v) col line ht #f qq) 'paren-shape (shaped-parens-shape v))] [(just-context? v) - (let ([s (do-syntax-ize (just-context-val v) col line ht #f)]) + (let ([s (do-syntax-ize (just-context-val v) col line ht #f qq)]) (datum->syntax (just-context-ctx v) (syntax-e s) s s (just-context-ctx v)))] [(alternate-display? v) - (let ([s (do-syntax-ize (alternate-display-id v) col line ht #f)]) + (let ([s (do-syntax-ize (alternate-display-id v) col line ht #f qq)]) (syntax-property s 'display-string (alternate-display-string v)))] @@ -802,23 +851,38 @@ (vector #f line col (+ 1 col) 1)))] [(and (list? v) (pair? v) - (memq (let ([s (car v)]) - (if (just-context? s) - (just-context-val s) - s)) - '(quote unquote unquote-splicing))) - (let ([c (do-syntax-ize (cadr v) (+ col 1) line ht #f)]) - (datum->syntax #f - (list (do-syntax-ize (car v) col line ht #f) - c) - (vector #f line col (+ 1 col) - (+ 1 (syntax-span c)))))] + (let ([s (let ([s (car v)]) + (if (just-context? s) + (just-context-val s) + s))]) + (and + (or (memq s '(quaisquote quote)) + (and (memq s '(unquote unquote-splicing)) + (or (not qq) + (qq . > . 2)))) + s))) + => (lambda (s) + (let ([c (do-syntax-ize (cadr v) (+ col 1) line ht #f qq)]) + (datum->syntax #f + (list (do-syntax-ize (car v) col line ht #f + (and qq + (case s + [(quaisquote) (add1 qq)] + [(unquote unquote-splicing) (sub1 qq)] + [else qq]))) + c) + (vector #f line col (+ 1 col) + (+ 1 (syntax-span c))))))] [(or (list? v) (vector? v) (and (struct? v) - (prefab-struct-key v))) + (or (and qq + ;; Watch out for partially transparent subtypes of `element': + (not (element? v))) + (prefab-struct-key v)))) (let ([orig-ht (unbox ht)] - [graph-box (box (graph-count ht graph?))]) + [graph-box (box (graph-count ht graph?))] + [qq (and qq (max 1 qq))]) (set-box! ht (hash-set (unbox ht) v graph-box)) (let* ([graph-sz (if graph? (+ 2 (string-length (format "~a" (unbox graph-box)))) @@ -826,26 +890,35 @@ [vec-sz (cond [(vector? v) (+ 1 #;(string-length (format "~a" (vector-length v))))] - [(struct? v) 2] + [(struct? v) + (if (prefab-struct-key v) + 2 + 0)] [else 0])] [r (let ([l (let loop ([col (+ col 1 vec-sz graph-sz)] [v (cond [(vector? v) (vector->short-list v values)] [(struct? v) - (cons (prefab-struct-key v) + (cons (let ([pf (prefab-struct-key v)]) + (if pf + (prefab-struct-key v) + (object-name v))) (cdr (vector->list (struct->vector v))))] [else v])]) (if (null? v) null - (let ([i (do-syntax-ize (car v) col line ht #f)]) + (let ([i (do-syntax-ize (car v) col line ht #f qq)]) (cons i (loop (+ col 1 (syntax-span i)) (cdr v))))))]) (datum->syntax #f (cond [(vector? v) (short-list->vector v l)] [(struct? v) - (apply make-prefab-struct (prefab-struct-key v) (cdr l))] + (let ([pf (prefab-struct-key v)]) + (if pf + (apply make-prefab-struct (prefab-struct-key v) (cdr l)) + (make-struct-proxy (car l) (cdr l))))] [else l]) (vector #f line (+ graph-sz col) @@ -868,22 +941,23 @@ [(unbox graph-box) ;; Go again, this time knowing that there will be a graph: (set-box! ht orig-ht) - (do-syntax-ize v col line ht #t)] + (do-syntax-ize v col line ht #t qq)] [else r])))] [(pair? v) (let ([orig-ht (unbox ht)] - [graph-box (box (graph-count ht graph?))]) + [graph-box (box (graph-count ht graph?))] + [qq (and qq (max 1 qq))]) (set-box! ht (hash-set (unbox ht) v graph-box)) (let* ([inc (if graph? (+ 2 (string-length (format "~a" (unbox graph-box)))) 0)] - [a (do-syntax-ize (car v) (+ col 1 inc) line ht #f)] + [a (do-syntax-ize (car v) (+ col 1 inc) line ht #f qq)] [sep (if (and (pair? (cdr v)) ;; FIXME: what if it turns out to be a graph reference? (not (hash-ref (unbox ht) (cdr v) #f))) 0 3)] - [b (do-syntax-ize (cdr v) (+ col 1 inc (syntax-span a) sep) line ht #f)]) + [b (do-syntax-ize (cdr v) (+ col 1 inc (syntax-span a) sep) line ht #f qq)]) (let ([r (datum->syntax #f (cons a b) (vector #f line (+ col inc) (+ 1 col inc) @@ -898,10 +972,10 @@ [(unbox graph-box) ;; Go again... (set-box! ht orig-ht) - (do-syntax-ize v col line ht #t)] + (do-syntax-ize v col line ht #t qq)] [else r]))))] [(box? v) - (let ([a (do-syntax-ize (unbox v) (+ col 2) line ht #f)]) + (let ([a (do-syntax-ize (unbox v) (+ col 2) line ht #f (and qq (max 1 qq)))]) (datum->syntax #f (box a) (vector #f line col (+ 1 col) diff --git a/collects/scribblings/scribble/manual.scrbl b/collects/scribblings/scribble/manual.scrbl index a62f9b34..8736312c 100644 --- a/collects/scribblings/scribble/manual.scrbl +++ b/collects/scribblings/scribble/manual.scrbl @@ -112,6 +112,13 @@ A few other escapes are recognized symbolically: @item{@schemeidfont{code:blank} typesets as a blank space.} + @item{@scheme[(#,(scheme code:hilite) _datum)] typesets like + @scheme[_datum], but with a background highlight.} + + @item{@scheme[(#,(scheme code:quote) _datum)] typesets like + @scheme[(@#,schemeidfont{quote} _datum)], but without rendering the + @schemeidfont{quote} as @litchar{'}.} + @item{@schemeidfont{_}@scheme[_id] typesets as @scheme[id], but colored as a variable (like @scheme[schemevarfont]); this escape applies only if @schemeidfont{_}@scheme[_id] has no diff --git a/collects/scribblings/scribble/reader-internals.scrbl b/collects/scribblings/scribble/reader-internals.scrbl index 9e0240e1..4086e29d 100644 --- a/collects/scribblings/scribble/reader-internals.scrbl +++ b/collects/scribblings/scribble/reader-internals.scrbl @@ -149,7 +149,7 @@ is an example of this. @defmodulelang[at-exp]{The @schememodname[at-exp] language installs @"@"-reader support in the readtable, and then chains to the reader of -another language that is specified immediate after +another language that is specified immediately after @schememodname[at-exp].} For example, @scheme[@#,hash-lang[] at-exp scheme/base] adds @"@"-reader diff --git a/collects/scribblings/scribble/scheme.scrbl b/collects/scribblings/scribble/scheme.scrbl index 4f98ff2b..9285fecf 100644 --- a/collects/scribblings/scribble/scheme.scrbl +++ b/collects/scribblings/scribble/scheme.scrbl @@ -41,7 +41,7 @@ The @scheme[stx-prop-expr] should produce a procedure for recording a @scheme[id] has such a property. The default is @scheme[syntax-property].} -@defproc[(to-paragraph [v any/c]) block?]{ +@defproc[(to-paragraph [v any/c] [#:qq? qq? any/c #f]) block?]{ Typesets an S-expression that is represented by a syntax object, where source-location information in the syntax object controls the @@ -50,18 +50,26 @@ generated layout. Identifiers that have @scheme[for-label] bindings are typeset and hyperlinked based on definitions declared elsewhere (via @scheme[defproc], @scheme[defform], etc.). The identifiers -@schemeidfont{code:line}, @schemeidfont{code:comment}, and -@schemeidfont{code:blank} are handled as in @scheme[schemeblock], as +@schemeidfont{code:line}, @schemeidfont{code:comment}, +@schemeidfont{code:blank}, @schemeidfont{code:hilite}, and +@schemeidfont{code:quote} are handled as in @scheme[schemeblock], as are identifiers that start with @litchar{_}. In addition, the given @scheme[v] can contain @scheme[var-id], @scheme[shaped-parens], @scheme[just-context], or @scheme[literal-syntax] structures to be typeset specially (see each structure type for details), or it can contain @scheme[element] -structures that are used directly in the output.} +structures that are used directly in the output. + +If @scheme[qq?] is true, then @scheme[v] is rendered ``quasiquote'' +style, much like @scheme[print] with the @scheme[print-as-quasiquote] +parameter set to @scheme[#t]. In that case, @scheme[for-label] +bindings on identifiers are ignored, since the identifiers are all +quoted in the output. Typically, @scheme[qq?] is set to true for +printing result values.} -@defproc[((to-paragraph/prefix [prefix1 any/c] [prefix any/c] [suffix any/c]) +@defproc[((to-paragraph/prefix [prefix1 any/c] [prefix any/c] [suffix any/c] [#:qq? qq? any/c #f]) [v any/c]) block?]{ @@ -73,13 +81,13 @@ first line, @scheme[prefix] is prefix to any subsequent line, and it is added to the end on its own line.} -@defproc[(to-element [v any/c]) element?]{ +@defproc[(to-element [v any/c] [#:qq? qq? any/c #f]) element?]{ Like @scheme[to-paragraph], except that source-location information is mostly ignored, since the result is meant to be inlined into a paragraph.} -@defproc[(to-element/no-color [v any/c]) element?]{ +@defproc[(to-element/no-color [v any/c] [#:qq? qq? any/c #f]) element?]{ Like @scheme[to-element], but @scheme[for-syntax] bindings are ignored, and the generated text is uncolored. This variant is