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
This commit is contained in:
Matthew Flatt
parent
142609a67b
commit
fbd04f4e97
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user