convert racket value printer to constructor+quote style; update Guide and Quick
original commit: 420ea6ee0962cac112853c23e756534cb307ad62
This commit is contained in:
Matthew Flatt
parent
8a38388cd7
commit
eeee9df37e
|
|
@ -124,7 +124,7 @@
|
||||||
(list
|
(list
|
||||||
(hspace 2)
|
(hspace 2)
|
||||||
(elem #:style result-color
|
(elem #:style result-color
|
||||||
(to-element/no-color v #:qq? (print-as-expression)))))))))
|
(to-element/no-color v #:expr? (print-as-expression)))))))))
|
||||||
val-list))))
|
val-list))))
|
||||||
(loop (cdr expr-paras)
|
(loop (cdr expr-paras)
|
||||||
(cdr val-list+outputs)
|
(cdr val-list+outputs)
|
||||||
|
|
@ -320,7 +320,7 @@
|
||||||
|
|
||||||
(define (show-val v)
|
(define (show-val v)
|
||||||
(elem #:style result-color
|
(elem #:style result-color
|
||||||
(to-element/no-color v #:qq? (print-as-expression))))
|
(to-element/no-color v #:expr? (print-as-expression))))
|
||||||
|
|
||||||
(define (do-interaction-eval-show ev e)
|
(define (do-interaction-eval-show ev e)
|
||||||
(parameterize ([current-command-line-arguments #()])
|
(parameterize ([current-command-line-arguments #()])
|
||||||
|
|
|
||||||
|
|
@ -162,23 +162,25 @@
|
||||||
e))))
|
e))))
|
||||||
(make-element style content)))
|
(make-element style content)))
|
||||||
|
|
||||||
(define (to-quoted qs qq? quote-depth out color? inc!)
|
(define (to-quoted obj expr? quote-depth out color? inc!)
|
||||||
(if (and qq? (zero? quote-depth))
|
(if (and expr?
|
||||||
|
(zero? quote-depth)
|
||||||
|
(quotable? obj))
|
||||||
(begin
|
(begin
|
||||||
(out qs (and color? value-color))
|
(out "'" (and color? value-color))
|
||||||
(inc!)
|
(inc!)
|
||||||
(add1 quote-depth))
|
(add1 quote-depth))
|
||||||
quote-depth))
|
quote-depth))
|
||||||
|
|
||||||
(define (to-unquoted qq? quote-depth out color? inc!)
|
(define (to-unquoted expr? quote-depth out color? inc!)
|
||||||
(if (or (not qq?) (zero? quote-depth))
|
(if (or (not expr?) (zero? quote-depth))
|
||||||
quote-depth
|
quote-depth
|
||||||
(begin
|
(begin
|
||||||
(out "," (and color? meta-color))
|
(out "," (and color? meta-color))
|
||||||
(inc!)
|
(inc!)
|
||||||
(to-unquoted qq? (sub1 quote-depth) out color? inc!))))
|
(to-unquoted expr? (sub1 quote-depth) out color? inc!))))
|
||||||
|
|
||||||
(define (typeset-atom c out color? quote-depth qq?)
|
(define (typeset-atom c out color? quote-depth expr?)
|
||||||
(if (and (var-id? (syntax-e c))
|
(if (and (var-id? (syntax-e c))
|
||||||
(zero? quote-depth))
|
(zero? quote-depth))
|
||||||
(out (format "~s" (let ([v (var-id-sym (syntax-e c))])
|
(out (format "~s" (let ([v (var-id-sym (syntax-e c))])
|
||||||
|
|
@ -203,13 +205,13 @@
|
||||||
is-var?)))
|
is-var?)))
|
||||||
(values (substring s 1) #t #f)
|
(values (substring s 1) #t #f)
|
||||||
(values s #f #f))))])
|
(values s #f #f))))])
|
||||||
(let ([quote-depth (if (and qq? (identifier? c) (not (eq? qq-ellipses (syntax-e c))))
|
(let ([quote-depth (if (and expr? (identifier? c) (not (eq? qq-ellipses (syntax-e c))))
|
||||||
(let ([quote-depth
|
(let ([quote-depth
|
||||||
(if (and (quote-depth . < . 2)
|
(if (and (quote-depth . < . 2)
|
||||||
(memq (syntax-e c) '(unquote unquote-splicing)))
|
(memq (syntax-e c) '(unquote unquote-splicing)))
|
||||||
(to-unquoted qq? quote-depth out color? void)
|
(to-unquoted expr? quote-depth out color? void)
|
||||||
quote-depth)])
|
quote-depth)])
|
||||||
(to-quoted "'" qq? quote-depth out color? void))
|
(to-quoted c expr? quote-depth out color? void))
|
||||||
quote-depth)])
|
quote-depth)])
|
||||||
(if (or (element? (syntax-e c))
|
(if (or (element? (syntax-e c))
|
||||||
(delayed-element? (syntax-e c))
|
(delayed-element? (syntax-e c))
|
||||||
|
|
@ -251,8 +253,8 @@
|
||||||
|
|
||||||
(define omitable (make-style #f '(omitable)))
|
(define omitable (make-style #f '(omitable)))
|
||||||
|
|
||||||
(define (gen-typeset c multi-line? prefix1 prefix suffix color? qq?)
|
(define (gen-typeset c multi-line? prefix1 prefix suffix color? expr?)
|
||||||
(let* ([c (syntax-ize c 0 #:qq? qq?)]
|
(let* ([c (syntax-ize c 0 #:expr? expr?)]
|
||||||
[content null]
|
[content null]
|
||||||
[docs null]
|
[docs null]
|
||||||
[first (syntax-case c (code:line)
|
[first (syntax-case c (code:line)
|
||||||
|
|
@ -341,7 +343,7 @@
|
||||||
(set! src-col c)
|
(set! src-col c)
|
||||||
(hash-set! next-col-map src-col dest-col)))]
|
(hash-set! next-col-map src-col dest-col)))]
|
||||||
[(c init-line!) (advance c init-line! 0)]))
|
[(c init-line!) (advance c init-line! 0)]))
|
||||||
(define (convert-infix c quote-depth qq?)
|
(define (convert-infix c quote-depth expr?)
|
||||||
(let ([l (syntax->list c)])
|
(let ([l (syntax->list c)])
|
||||||
(and l
|
(and l
|
||||||
((length l) . >= . 3)
|
((length l) . >= . 3)
|
||||||
|
|
@ -367,7 +369,7 @@
|
||||||
(if val? value-color #f)
|
(if val? value-color #f)
|
||||||
(list
|
(list
|
||||||
(make-element/cache (if val? value-color paren-color) '". ")
|
(make-element/cache (if val? value-color paren-color) '". ")
|
||||||
(typeset a #f "" "" "" (not val?) qq?)
|
(typeset a #f "" "" "" (not val?) expr?)
|
||||||
(make-element/cache (if val? value-color paren-color) '" ."))
|
(make-element/cache (if val? value-color paren-color) '" ."))
|
||||||
(+ (syntax-span a) 4)))
|
(+ (syntax-span a) 4)))
|
||||||
(list (syntax-source a)
|
(list (syntax-source a)
|
||||||
|
|
@ -385,7 +387,7 @@
|
||||||
(cond
|
(cond
|
||||||
[(eq? s 'rsquo) "'"]
|
[(eq? s 'rsquo) "'"]
|
||||||
[else s]))
|
[else s]))
|
||||||
(define (loop init-line! quote-depth qq?)
|
(define (loop init-line! quote-depth expr? no-cons?)
|
||||||
(lambda (c)
|
(lambda (c)
|
||||||
(cond
|
(cond
|
||||||
[(eq? 'code:blank (syntax-e c))
|
[(eq? 'code:blank (syntax-e c))
|
||||||
|
|
@ -422,12 +424,13 @@
|
||||||
(set! dest-col 0)
|
(set! dest-col 0)
|
||||||
(out "; " comment-color))
|
(out "; " comment-color))
|
||||||
0
|
0
|
||||||
qq?)
|
expr?
|
||||||
|
#f)
|
||||||
l))]
|
l))]
|
||||||
[(and (pair? (syntax-e c))
|
[(and (pair? (syntax-e c))
|
||||||
(eq? (syntax-e (car (syntax-e c))) 'code:line))
|
(eq? (syntax-e (car (syntax-e c))) 'code:line))
|
||||||
(let ([l (cdr (syntax->list c))])
|
(let ([l (cdr (syntax->list c))])
|
||||||
(for-each (loop init-line! quote-depth qq?)
|
(for-each (loop init-line! quote-depth expr? #f)
|
||||||
l))]
|
l))]
|
||||||
[(and (pair? (syntax-e c))
|
[(and (pair? (syntax-e c))
|
||||||
(eq? (syntax-e (car (syntax-e c))) 'code:hilite))
|
(eq? (syntax-e (car (syntax-e c))) 'code:hilite))
|
||||||
|
|
@ -439,19 +442,19 @@
|
||||||
(set! src-col (syntax-column (cadr l)))
|
(set! src-col (syntax-column (cadr l)))
|
||||||
(hash-set! next-col-map src-col dest-col)
|
(hash-set! next-col-map src-col dest-col)
|
||||||
(set! highlight? #t)
|
(set! highlight? #t)
|
||||||
((loop init-line! quote-depth qq?) (cadr l))
|
((loop init-line! quote-depth expr?) (cadr l) #f)
|
||||||
(set! highlight? h?)
|
(set! highlight? h?)
|
||||||
(set! src-col (add1 src-col)))]
|
(set! src-col (add1 src-col)))]
|
||||||
[(and (pair? (syntax-e c))
|
[(and (pair? (syntax-e c))
|
||||||
(eq? (syntax-e (car (syntax-e c))) 'code:quote))
|
(eq? (syntax-e (car (syntax-e c))) 'code:quote))
|
||||||
(advance c init-line!)
|
(advance c init-line!)
|
||||||
(let ([quote-depth (to-quoted "`" qq? quote-depth out color? inc-src-col)])
|
(let ([quote-depth (to-quoted c expr? quote-depth out color? inc-src-col)])
|
||||||
(out "(" (if (positive? quote-depth) value-color paren-color))
|
(out "(" (if (positive? quote-depth) value-color paren-color))
|
||||||
(set! src-col (+ src-col 1))
|
(set! src-col (+ src-col 1))
|
||||||
(hash-set! next-col-map src-col dest-col)
|
(hash-set! next-col-map src-col dest-col)
|
||||||
((loop init-line! quote-depth qq?)
|
((loop init-line! quote-depth expr? #f)
|
||||||
(datum->syntax #'here 'quote (car (syntax-e c))))
|
(datum->syntax #'here 'quote (car (syntax-e c))))
|
||||||
(for-each (loop init-line! (add1 quote-depth) qq?)
|
(for-each (loop init-line! (add1 quote-depth) expr? #f)
|
||||||
(cdr (syntax->list c)))
|
(cdr (syntax->list c)))
|
||||||
(out ")" (if (positive? quote-depth) value-color paren-color))
|
(out ")" (if (positive? quote-depth) value-color paren-color))
|
||||||
(set! src-col (+ src-col 1))
|
(set! src-col (+ src-col 1))
|
||||||
|
|
@ -463,12 +466,11 @@
|
||||||
quasisyntax syntax unsyntax unsyntax-splicing))
|
quasisyntax syntax unsyntax unsyntax-splicing))
|
||||||
(let ([v (syntax->list c)])
|
(let ([v (syntax->list c)])
|
||||||
(and v (= 2 (length v))))
|
(and v (= 2 (length v))))
|
||||||
(or (not qq?)
|
(or (not expr?)
|
||||||
(quote-depth . > . 1)
|
(positive? quote-depth)
|
||||||
(not (memq (syntax-e (car (syntax-e c)))
|
(quotable? c)))
|
||||||
'(unquote unquote-splicing)))))
|
|
||||||
(advance c init-line!)
|
(advance c init-line!)
|
||||||
(let ([quote-depth (to-quoted "`" qq? quote-depth out color? inc-src-col)])
|
(let ([quote-depth (to-quoted c expr? quote-depth out color? inc-src-col)])
|
||||||
(let-values ([(str quote-delta)
|
(let-values ([(str quote-delta)
|
||||||
(case (syntax-e (car (syntax-e c)))
|
(case (syntax-e (car (syntax-e c)))
|
||||||
[(quote) (values "'" +inf.0)]
|
[(quote) (values "'" +inf.0)]
|
||||||
|
|
@ -485,12 +487,16 @@
|
||||||
(let ([i (cadr (syntax->list c))])
|
(let ([i (cadr (syntax->list c))])
|
||||||
(set! src-col (or (syntax-column i) src-col))
|
(set! src-col (or (syntax-column i) src-col))
|
||||||
(hash-set! next-col-map src-col dest-col)
|
(hash-set! next-col-map src-col dest-col)
|
||||||
((loop init-line! (+ quote-depth quote-delta) qq?) i))))]
|
((loop init-line! (+ quote-depth quote-delta) expr? #f) i))))]
|
||||||
[(and (pair? (syntax-e c))
|
[(and (pair? (syntax-e c))
|
||||||
(convert-infix c quote-depth qq?))
|
(or (not expr?)
|
||||||
|
(positive? quote-depth)
|
||||||
|
(quotable? c))
|
||||||
|
(convert-infix c quote-depth expr?))
|
||||||
=> (lambda (converted)
|
=> (lambda (converted)
|
||||||
((loop init-line! quote-depth qq?) converted))]
|
((loop init-line! quote-depth expr? #f) converted))]
|
||||||
[(or (pair? (syntax-e c))
|
[(or (pair? (syntax-e c))
|
||||||
|
(mpair? (syntax-e c))
|
||||||
(forced-pair? (syntax-e c))
|
(forced-pair? (syntax-e c))
|
||||||
(null? (syntax-e c))
|
(null? (syntax-e c))
|
||||||
(vector? (syntax-e c))
|
(vector? (syntax-e c))
|
||||||
|
|
@ -498,12 +504,15 @@
|
||||||
(prefab-struct-key (syntax-e c)))
|
(prefab-struct-key (syntax-e c)))
|
||||||
(struct-proxy? (syntax-e c)))
|
(struct-proxy? (syntax-e c)))
|
||||||
(let* ([sh (or (syntax-property c 'paren-shape)
|
(let* ([sh (or (syntax-property c 'paren-shape)
|
||||||
#\()]
|
(if (and (mpair? (syntax-e c))
|
||||||
[quote-depth (if (and (not qq?)
|
(not (and expr? (zero? quote-depth))))
|
||||||
|
#\{
|
||||||
|
#\())]
|
||||||
|
[quote-depth (if (and (not expr?)
|
||||||
(zero? quote-depth)
|
(zero? quote-depth)
|
||||||
(or (vector? (syntax-e c))
|
(or (vector? (syntax-e c))
|
||||||
(struct? (syntax-e c))))
|
(struct? (syntax-e c))))
|
||||||
+inf.0
|
1
|
||||||
quote-depth)]
|
quote-depth)]
|
||||||
[p-color (if (positive? quote-depth)
|
[p-color (if (positive? quote-depth)
|
||||||
value-color
|
value-color
|
||||||
|
|
@ -512,24 +521,50 @@
|
||||||
paren-color))])
|
paren-color))])
|
||||||
(advance c init-line!)
|
(advance c init-line!)
|
||||||
(let ([quote-depth (if (struct-proxy? (syntax-e c))
|
(let ([quote-depth (if (struct-proxy? (syntax-e c))
|
||||||
(to-unquoted qq? quote-depth out color? inc-src-col)
|
quote-depth
|
||||||
(to-quoted "`" qq? quote-depth out color? inc-src-col))])
|
(to-quoted c expr? quote-depth out color? inc-src-col))])
|
||||||
|
(when (and expr? (zero? quote-depth))
|
||||||
|
(out "(" p-color)
|
||||||
|
(unless no-cons?
|
||||||
|
(out (let ([s (cond
|
||||||
|
[(pair? (syntax-e c))
|
||||||
|
(if (syntax->list c)
|
||||||
|
"list"
|
||||||
|
(if (let ([d (cdr (syntax-e c))])
|
||||||
|
(or (pair? d)
|
||||||
|
(and (syntax? d)
|
||||||
|
(pair? (syntax-e d)))))
|
||||||
|
"list*"
|
||||||
|
"cons"))]
|
||||||
|
[(vector? (syntax-e c)) "vector"]
|
||||||
|
[(mpair? (syntax-e c)) "mcons"]
|
||||||
|
[else (format "~a"
|
||||||
|
(if (struct-proxy? (syntax-e c))
|
||||||
|
(syntax-e (struct-proxy-name (syntax-e c)))
|
||||||
|
(object-name (syntax-e c))))])])
|
||||||
|
(set! src-col (+ src-col (string-length s)))
|
||||||
|
s)
|
||||||
|
symbol-color)
|
||||||
|
(out " " no-color)))
|
||||||
(when (vector? (syntax-e c))
|
(when (vector? (syntax-e c))
|
||||||
(let ([vec (syntax-e c)])
|
(unless (and expr? (zero? quote-depth))
|
||||||
(out "#" #; (format "#~a" (vector-length vec)) p-color)
|
(let ([vec (syntax-e c)])
|
||||||
(if (zero? (vector-length vec))
|
(out "#" p-color)
|
||||||
(set! src-col (+ src-col (- (syntax-span c) 2)))
|
(if (zero? (vector-length vec))
|
||||||
(set! src-col (+ src-col (- (syntax-column (vector-ref vec 0))
|
(set! src-col (+ src-col (- (syntax-span c) 2)))
|
||||||
(syntax-column c)
|
(set! src-col (+ src-col (- (syntax-column (vector-ref vec 0))
|
||||||
1))))))
|
(syntax-column c)
|
||||||
|
1)))))))
|
||||||
(when (struct? (syntax-e c))
|
(when (struct? (syntax-e c))
|
||||||
(out "#s" p-color)
|
(unless (and expr? (zero? quote-depth))
|
||||||
(set! src-col (+ src-col 2)))
|
(out "#s" p-color)
|
||||||
(out (case sh
|
(set! src-col (+ src-col 2))))
|
||||||
[(#\[ #\?) "["]
|
(unless (and expr? (zero? quote-depth))
|
||||||
[(#\{) "{"]
|
(out (case sh
|
||||||
[else "("])
|
[(#\[ #\?) "["]
|
||||||
p-color)
|
[(#\{) "{"]
|
||||||
|
[else "("])
|
||||||
|
p-color))
|
||||||
(set! src-col (+ src-col 1))
|
(set! src-col (+ src-col 1))
|
||||||
(hash-set! next-col-map src-col dest-col)
|
(hash-set! next-col-map src-col dest-col)
|
||||||
(let lloop ([l (cond
|
(let lloop ([l (cond
|
||||||
|
|
@ -539,31 +574,33 @@
|
||||||
(let ([l (vector->list (struct->vector (syntax-e c)))])
|
(let ([l (vector->list (struct->vector (syntax-e c)))])
|
||||||
;; Need to build key datum, syntax-ize it internally, and
|
;; Need to build key datum, syntax-ize it internally, and
|
||||||
;; set the overall width to fit right:
|
;; set the overall width to fit right:
|
||||||
(cons (let ([key (syntax-ize (prefab-struct-key (syntax-e c))
|
(if (and expr? (zero? quote-depth))
|
||||||
(+ 3 (or (syntax-column c) 0))
|
(cdr l)
|
||||||
(or (syntax-line c) 1))]
|
(cons (let ([key (syntax-ize (prefab-struct-key (syntax-e c))
|
||||||
[end (if (pair? (cdr l))
|
(+ 3 (or (syntax-column c) 0))
|
||||||
(and (equal? (syntax-line c) (syntax-line (cadr l)))
|
(or (syntax-line c) 1))]
|
||||||
(syntax-column (cadr l)))
|
[end (if (pair? (cdr l))
|
||||||
(and (syntax-column c)
|
(and (equal? (syntax-line c) (syntax-line (cadr l)))
|
||||||
(+ (syntax-column c) (syntax-span c))))])
|
(syntax-column (cadr l)))
|
||||||
(if end
|
(and (syntax-column c)
|
||||||
(datum->syntax #f
|
(+ (syntax-column c) (syntax-span c))))])
|
||||||
(syntax-e key)
|
(if end
|
||||||
(vector #f (syntax-line key)
|
(datum->syntax #f
|
||||||
(syntax-column key)
|
(syntax-e key)
|
||||||
(syntax-position key)
|
(vector #f (syntax-line key)
|
||||||
(- end 1 (syntax-column key))))
|
(syntax-column key)
|
||||||
end))
|
(syntax-position key)
|
||||||
(cdr l)))]
|
(max 1 (- end 1 (syntax-column key)))))
|
||||||
|
end))
|
||||||
|
(cdr l))))]
|
||||||
[(struct-proxy? (syntax-e c))
|
[(struct-proxy? (syntax-e c))
|
||||||
(cons
|
(struct-proxy-content (syntax-e c))]
|
||||||
(struct-proxy-name (syntax-e c))
|
|
||||||
(struct-proxy-content (syntax-e c)))]
|
|
||||||
[(forced-pair? (syntax-e c))
|
[(forced-pair? (syntax-e c))
|
||||||
(syntax-e c)]
|
(syntax-e c)]
|
||||||
|
[(mpair? (syntax-e c))
|
||||||
|
(syntax-e c)]
|
||||||
[else c])]
|
[else c])]
|
||||||
[first-qq? (and qq? (not (struct-proxy? (syntax-e c))))]
|
[first-expr? (and expr? (not (struct-proxy? (syntax-e c))) (not no-cons?))]
|
||||||
[dotted? #f])
|
[dotted? #f])
|
||||||
(cond
|
(cond
|
||||||
[(and (syntax? l)
|
[(and (syntax? l)
|
||||||
|
|
@ -573,76 +610,94 @@
|
||||||
'(quote unquote syntax unsyntax quasiquote quasiunsyntax))
|
'(quote unquote syntax unsyntax quasiquote quasiunsyntax))
|
||||||
(let ([v (syntax->list l)])
|
(let ([v (syntax->list l)])
|
||||||
(and v (= 2 (length v))))
|
(and v (= 2 (length v))))
|
||||||
(or (not qq?)
|
(or (not expr?)
|
||||||
(quote-depth . > . 1)
|
(quote-depth . > . 1)
|
||||||
(not (memq (syntax-e (car (syntax-e l)))
|
(not (memq (syntax-e (car (syntax-e l)))
|
||||||
'(unquote unquote-splicing)))))))
|
'(unquote unquote-splicing)))))))
|
||||||
(lloop (syntax-e l) first-qq? #f)]
|
(lloop (syntax-e l) first-expr? #f)]
|
||||||
[(or (null? l)
|
[(and (or (null? l)
|
||||||
(and (syntax? l)
|
(and (syntax? l)
|
||||||
(null? (syntax-e l))))
|
(null? (syntax-e l)))))
|
||||||
(void)]
|
(void)]
|
||||||
[(and (pair? l) (not dotted?))
|
[(and (pair? l) (not dotted?))
|
||||||
((loop init-line! quote-depth first-qq?) (car l))
|
((loop init-line! quote-depth first-expr? #f) (car l))
|
||||||
(lloop (cdr l) qq? #f)]
|
(lloop (cdr l) expr? #f)]
|
||||||
[(forced-pair? l)
|
[(forced-pair? l)
|
||||||
((loop init-line! quote-depth first-qq?) (forced-pair-car l))
|
((loop init-line! quote-depth first-expr? #f) (forced-pair-car l))
|
||||||
(lloop (forced-pair-cdr l) qq? #t)]
|
(lloop (forced-pair-cdr l) expr? #t)]
|
||||||
|
[(mpair? l)
|
||||||
|
((loop init-line! quote-depth first-expr? #f) (mcar l))
|
||||||
|
(lloop (mcdr l) expr? #t)]
|
||||||
[else
|
[else
|
||||||
(advance l init-line! -2)
|
(unless (and expr? (zero? quote-depth))
|
||||||
(out ". " (if (positive? quote-depth) value-color paren-color))
|
(advance l init-line! -2)
|
||||||
(set! src-col (+ src-col 3))
|
(out ". " (if (positive? quote-depth) value-color paren-color))
|
||||||
|
(set! src-col (+ src-col 3)))
|
||||||
(hash-set! next-col-map src-col dest-col)
|
(hash-set! next-col-map src-col dest-col)
|
||||||
((loop init-line! quote-depth first-qq?) l)]))
|
((loop init-line! quote-depth first-expr? #f) l)]))
|
||||||
(out (case sh
|
(out (case sh
|
||||||
[(#\[ #\?) "]"]
|
[(#\[ #\?) "]"]
|
||||||
[(#\{) "}"]
|
[(#\{) "}"]
|
||||||
[else ")"])
|
[else ")"])
|
||||||
p-color)
|
p-color)
|
||||||
(set! src-col (+ src-col 1))
|
(set! src-col (+ src-col 1))))]
|
||||||
#;
|
|
||||||
(hash-set! next-col-map src-col dest-col)))]
|
|
||||||
[(box? (syntax-e c))
|
[(box? (syntax-e c))
|
||||||
(advance c init-line!)
|
(advance c init-line!)
|
||||||
(let ([quote-depth (to-quoted "`" qq? quote-depth out color? inc-src-col)])
|
(let ([quote-depth (to-quoted c expr? quote-depth out color? inc-src-col)])
|
||||||
(out "#&" value-color)
|
(if (and expr? (zero? quote-depth))
|
||||||
(set! src-col (+ src-col 2))
|
(begin
|
||||||
|
(out "(" paren-color)
|
||||||
|
(out "box" symbol-color)
|
||||||
|
(out " " no-color)
|
||||||
|
(set! src-col (+ src-col 5)))
|
||||||
|
(begin
|
||||||
|
(out "#&" value-color)
|
||||||
|
(set! src-col (+ src-col 2))))
|
||||||
(hash-set! next-col-map src-col dest-col)
|
(hash-set! next-col-map src-col dest-col)
|
||||||
((loop init-line! (if qq? quote-depth +inf.0) qq?) (unbox (syntax-e c))))]
|
((loop init-line! (if expr? quote-depth +inf.0) expr? #f) (unbox (syntax-e c)))
|
||||||
|
(when (and expr? (zero? quote-depth))
|
||||||
|
(out ")" paren-color)))]
|
||||||
[(hash? (syntax-e c))
|
[(hash? (syntax-e c))
|
||||||
(advance c init-line!)
|
(advance c init-line!)
|
||||||
(let ([equal-table? (hash-equal? (syntax-e c))]
|
(let ([equal-table? (hash-equal? (syntax-e c))]
|
||||||
[eqv-table? (hash-eq? (syntax-e c))]
|
[eqv-table? (hash-eq? (syntax-e c))]
|
||||||
[quote-depth (to-quoted "`" qq? quote-depth out color? inc-src-col)])
|
[quote-depth (to-quoted c expr? quote-depth out color? inc-src-col)])
|
||||||
(out (if equal-table?
|
(unless (and expr? (zero? quote-depth))
|
||||||
"#hash"
|
(out (if equal-table?
|
||||||
(if eqv-table?
|
"#hash"
|
||||||
"#hasheqv"
|
(if eqv-table?
|
||||||
"#hasheq"))
|
"#hasheqv"
|
||||||
value-color)
|
"#hasheq"))
|
||||||
(let ([delta (+ 5 (if equal-table? 0 (if eqv-table? 3 2)))]
|
value-color))
|
||||||
|
(let ([delta (+ 5 (if equal-table? 0 (if eqv-table? 3 2))
|
||||||
|
(if (and expr? (zero? quote-depth)) 1 0))]
|
||||||
[orig-col src-col])
|
[orig-col src-col])
|
||||||
(set! src-col (+ src-col delta))
|
(set! src-col (+ src-col delta))
|
||||||
(hash-set! next-col-map src-col dest-col)
|
(hash-set! next-col-map src-col dest-col)
|
||||||
((loop init-line! (if qq? quote-depth +inf.0) qq?)
|
((loop init-line! (if expr? quote-depth +inf.0) expr? (and expr? (zero? quote-depth)))
|
||||||
(let*-values ([(l) (sort (hash-map (syntax-e c) cons)
|
(let*-values ([(l) (sort (hash-map (syntax-e c) cons)
|
||||||
(lambda (a b)
|
(lambda (a b)
|
||||||
(< (or (syntax-position (cdr a)) -inf.0)
|
(< (or (syntax-position (cdr a)) -inf.0)
|
||||||
(or (syntax-position (cdr b)) -inf.0))))]
|
(or (syntax-position (cdr b)) -inf.0))))]
|
||||||
[(col0) (+ (syntax-column c) delta 2)]
|
[(sep cap) (if (and expr? (zero? quote-depth))
|
||||||
|
(values 1 0)
|
||||||
|
(values 3 1))]
|
||||||
|
[(col0) (+ (syntax-column c) delta cap 1)]
|
||||||
[(l2 pos line) (for/fold ([l2 null][col col0][line (syntax-line c)])
|
[(l2 pos line) (for/fold ([l2 null][col col0][line (syntax-line c)])
|
||||||
([p (in-list l)])
|
([p (in-list l)])
|
||||||
(let* ([tentative (syntax-ize (car p) 0)]
|
(let* ([tentative (syntax-ize (car p) 0
|
||||||
|
#:expr? (and expr? (zero? quote-depth)))]
|
||||||
[width (syntax-span tentative)]
|
[width (syntax-span tentative)]
|
||||||
[col (if (= line (syntax-line (cdr p)))
|
[col (if (= line (syntax-line (cdr p)))
|
||||||
col
|
col
|
||||||
col0)])
|
col0)])
|
||||||
(let ([key
|
(let ([key
|
||||||
(let ([e (syntax-ize (car p)
|
(let ([e (syntax-ize (car p)
|
||||||
(max 0 (- (syntax-column (cdr p))
|
(max 0 (- (syntax-column (cdr p))
|
||||||
width
|
width
|
||||||
3))
|
sep))
|
||||||
(syntax-line (cdr p)))])
|
(syntax-line (cdr p))
|
||||||
|
#:expr? (and expr? (zero? quote-depth)))])
|
||||||
(if ((syntax-column e) . <= . col)
|
(if ((syntax-column e) . <= . col)
|
||||||
e
|
e
|
||||||
(datum->syntax #f
|
(datum->syntax #f
|
||||||
|
|
@ -658,17 +713,42 @@
|
||||||
(make-forced-pair key (cdr p))
|
(make-forced-pair key (cdr p))
|
||||||
(vector 'here
|
(vector 'here
|
||||||
(syntax-line (cdr p))
|
(syntax-line (cdr p))
|
||||||
(max 0 (- (syntax-column key) 1))
|
(max 0 (- (syntax-column key) cap))
|
||||||
(max 1 (- (syntax-position key) 1))
|
(max 1 (- (syntax-position key) cap))
|
||||||
(+ (syntax-span (cdr p)) (syntax-span key) 5)))])
|
(+ (syntax-span (cdr p)) (syntax-span key) sep cap cap)))])
|
||||||
(values (cons elem l2)
|
(values (cons elem l2)
|
||||||
(+ (syntax-column elem) (syntax-span elem) 2)
|
(+ (syntax-column elem) (syntax-span elem) 2)
|
||||||
(syntax-line elem))))))])
|
(syntax-line elem))))))])
|
||||||
(datum->syntax #f (reverse l2) (vector (syntax-source c)
|
(if (and expr? (zero? quote-depth))
|
||||||
(syntax-line c)
|
;; constructed:
|
||||||
(+ (syntax-column c) delta)
|
(let ([l (apply append
|
||||||
(+ (syntax-position c) delta)
|
(map (lambda (p)
|
||||||
(max 1 (- (syntax-span c) delta))))))
|
(let ([p (syntax-e p)])
|
||||||
|
(list (forced-pair-car p)
|
||||||
|
(forced-pair-cdr p))))
|
||||||
|
(reverse l2)))])
|
||||||
|
(datum->syntax
|
||||||
|
#f
|
||||||
|
(cons (let ([s (if equal-table?
|
||||||
|
'hash
|
||||||
|
(if eqv-table?
|
||||||
|
'hasheqv
|
||||||
|
'hasheq))])
|
||||||
|
(datum->syntax #f
|
||||||
|
s
|
||||||
|
(vector (syntax-source c)
|
||||||
|
(syntax-line c)
|
||||||
|
(+ (syntax-column c) 1)
|
||||||
|
(+ (syntax-position c) 1)
|
||||||
|
(string-length (symbol->string s)))))
|
||||||
|
l)
|
||||||
|
c))
|
||||||
|
;; quoted:
|
||||||
|
(datum->syntax #f (reverse l2) (vector (syntax-source c)
|
||||||
|
(syntax-line c)
|
||||||
|
(+ (syntax-column c) delta)
|
||||||
|
(+ (syntax-position c) delta)
|
||||||
|
(max 1 (- (syntax-span c) delta)))))))
|
||||||
(set! src-col (+ orig-col (syntax-span c)))))]
|
(set! src-col (+ orig-col (syntax-span c)))))]
|
||||||
[(graph-reference? (syntax-e c))
|
[(graph-reference? (syntax-e c))
|
||||||
(advance c init-line!)
|
(advance c init-line!)
|
||||||
|
|
@ -685,22 +765,22 @@
|
||||||
value-color
|
value-color
|
||||||
paren-color))
|
paren-color))
|
||||||
(set! src-col (+ src-col 3))
|
(set! src-col (+ src-col 3))
|
||||||
((loop init-line! quote-depth qq?) (graph-defn-r (syntax-e c))))]
|
((loop init-line! quote-depth expr? #f) (graph-defn-r (syntax-e c))))]
|
||||||
[(and (keyword? (syntax-e c)) qq?)
|
[(and (keyword? (syntax-e c)) expr?)
|
||||||
(advance c init-line!)
|
(advance c init-line!)
|
||||||
(let ([quote-depth (to-quoted "`" qq? quote-depth out color? inc-src-col)])
|
(let ([quote-depth (to-quoted c expr? quote-depth out color? inc-src-col)])
|
||||||
(typeset-atom c out color? quote-depth qq?)
|
(typeset-atom c out color? quote-depth expr?)
|
||||||
(set! src-col (+ src-col (or (syntax-span c) 1))))]
|
(set! src-col (+ src-col (or (syntax-span c) 1))))]
|
||||||
[else
|
[else
|
||||||
(advance c init-line!)
|
(advance c init-line!)
|
||||||
(typeset-atom c out color? quote-depth qq?)
|
(typeset-atom c out color? quote-depth expr?)
|
||||||
(set! src-col (+ src-col (or (syntax-span c) 1)))
|
(set! src-col (+ src-col (or (syntax-span c) 1)))
|
||||||
#;
|
#;
|
||||||
(hash-set! next-col-map src-col dest-col)])))
|
(hash-set! next-col-map src-col dest-col)])))
|
||||||
(out prefix1 #f)
|
(out prefix1 #f)
|
||||||
(set! dest-col 0)
|
(set! dest-col 0)
|
||||||
(hash-set! next-col-map init-col dest-col)
|
(hash-set! next-col-map init-col dest-col)
|
||||||
((loop (lambda () (set! src-col init-col) (set! dest-col 0)) 0 qq?) c)
|
((loop (lambda () (set! src-col init-col) (set! dest-col 0)) 0 expr? #f) c)
|
||||||
(if (list? suffix)
|
(if (list? suffix)
|
||||||
(map (lambda (sfx)
|
(map (lambda (sfx)
|
||||||
(finish-line!)
|
(finish-line!)
|
||||||
|
|
@ -715,12 +795,13 @@
|
||||||
(make-table block-color (map list (reverse docs))))
|
(make-table block-color (map list (reverse docs))))
|
||||||
(make-sized-element #f (reverse content) dest-col))))
|
(make-sized-element #f (reverse content) dest-col))))
|
||||||
|
|
||||||
(define (typeset c multi-line? prefix1 prefix suffix color? qq?)
|
(define (typeset c multi-line? prefix1 prefix suffix color? expr?)
|
||||||
(let* ([c (syntax-ize c 0 #:qq? qq?)]
|
(let* ([c (syntax-ize c 0 #:expr? expr?)]
|
||||||
[s (syntax-e c)])
|
[s (syntax-e c)])
|
||||||
(if (or multi-line?
|
(if (or multi-line?
|
||||||
(eq? 'code:blank s)
|
(eq? 'code:blank s)
|
||||||
(pair? s)
|
(pair? s)
|
||||||
|
(mpair? s)
|
||||||
(vector? s)
|
(vector? s)
|
||||||
(struct? s)
|
(struct? s)
|
||||||
(box? s)
|
(box? s)
|
||||||
|
|
@ -729,9 +810,9 @@
|
||||||
(graph-defn? s)
|
(graph-defn? s)
|
||||||
(graph-reference? s)
|
(graph-reference? s)
|
||||||
(struct-proxy? s)
|
(struct-proxy? s)
|
||||||
(and qq? (or (identifier? c)
|
(and expr? (or (identifier? c)
|
||||||
(keyword? (syntax-e c)))))
|
(keyword? (syntax-e c)))))
|
||||||
(gen-typeset c multi-line? prefix1 prefix suffix color? qq?)
|
(gen-typeset c multi-line? prefix1 prefix suffix color? expr?)
|
||||||
(typeset-atom c
|
(typeset-atom c
|
||||||
(letrec ([mk
|
(letrec ([mk
|
||||||
(case-lambda
|
(case-lambda
|
||||||
|
|
@ -743,19 +824,19 @@
|
||||||
(make-element/cache (and color? color) elem)
|
(make-element/cache (and color? color) elem)
|
||||||
(make-sized-element (and color? color) elem len))])])
|
(make-sized-element (and color? color) elem len))])])
|
||||||
mk)
|
mk)
|
||||||
color? 0 qq?))))
|
color? 0 expr?))))
|
||||||
|
|
||||||
(define (to-element c #:qq? [qq? #f])
|
(define (to-element c #:expr? [expr? #f])
|
||||||
(typeset c #f "" "" "" #t qq?))
|
(typeset c #f "" "" "" #t expr?))
|
||||||
|
|
||||||
(define (to-element/no-color c #:qq? [qq? #f])
|
(define (to-element/no-color c #:expr? [expr? #f])
|
||||||
(typeset c #f "" "" "" #f qq?))
|
(typeset c #f "" "" "" #f expr?))
|
||||||
|
|
||||||
(define (to-paragraph c #:qq? [qq? #f])
|
(define (to-paragraph c #:expr? [expr? #f])
|
||||||
(typeset c #t "" "" "" #t qq?))
|
(typeset c #t "" "" "" #t expr?))
|
||||||
|
|
||||||
(define ((to-paragraph/prefix pfx1 pfx sfx) c #:qq? [qq? #f])
|
(define ((to-paragraph/prefix pfx1 pfx sfx) c #:expr? [expr? #f])
|
||||||
(typeset c #t pfx1 pfx sfx #t qq?))
|
(typeset c #t pfx1 pfx sfx #t expr?))
|
||||||
|
|
||||||
(begin-for-syntax
|
(begin-for-syntax
|
||||||
(define-struct variable-id (sym)
|
(define-struct variable-id (sym)
|
||||||
|
|
@ -886,8 +967,8 @@
|
||||||
(define-struct graph-reference (bx))
|
(define-struct graph-reference (bx))
|
||||||
(define-struct graph-defn (r bx))
|
(define-struct graph-defn (r bx))
|
||||||
|
|
||||||
(define (syntax-ize v col [line 1] #:qq? [qq? #f])
|
(define (syntax-ize v col [line 1] #:expr? [expr? #f])
|
||||||
(do-syntax-ize v col line (box #hasheq()) #f (and qq? 0)))
|
(do-syntax-ize v col line (box #hasheq()) #f (and expr? 0) #f))
|
||||||
|
|
||||||
(define (graph-count ht graph?)
|
(define (graph-count ht graph?)
|
||||||
(and graph?
|
(and graph?
|
||||||
|
|
@ -897,23 +978,46 @@
|
||||||
|
|
||||||
(define-struct forced-pair (car cdr))
|
(define-struct forced-pair (car cdr))
|
||||||
|
|
||||||
(define (do-syntax-ize v col line ht graph? qq)
|
(define (quotable? v)
|
||||||
|
(cond
|
||||||
|
[(syntax? v) (quotable? (syntax-e v))]
|
||||||
|
[(pair? v) (and (quotable? (car v))
|
||||||
|
(quotable? (cdr v)))]
|
||||||
|
[(vector? v) (andmap quotable? (vector->list v))]
|
||||||
|
[(hash? v) (for/and ([(k v) (in-hash v)])
|
||||||
|
(and (quotable? k)
|
||||||
|
(quotable? v)))]
|
||||||
|
[(box? v) (quotable? (unbox v))]
|
||||||
|
[(and (struct? v)
|
||||||
|
(prefab-struct-key v))
|
||||||
|
(andmap quotable? (vector->list (struct->vector v)))]
|
||||||
|
[(struct? v) (if (custom-write? v)
|
||||||
|
(if (and (custom-print-as-constructor? v)
|
||||||
|
(custom-print-as-constructor-accessor v))
|
||||||
|
#f
|
||||||
|
#t)
|
||||||
|
#f)]
|
||||||
|
[(struct-proxy? v) #f]
|
||||||
|
[(mpair? v) #f]
|
||||||
|
[else #t]))
|
||||||
|
|
||||||
|
(define (do-syntax-ize v col line ht graph? qq no-cons?)
|
||||||
(cond
|
(cond
|
||||||
[((syntax-ize-hook) v col)
|
[((syntax-ize-hook) v col)
|
||||||
=> (lambda (r) r)]
|
=> (lambda (r) r)]
|
||||||
[(shaped-parens? v)
|
[(shaped-parens? v)
|
||||||
(syntax-property (do-syntax-ize (shaped-parens-val v) col line ht #f qq)
|
(syntax-property (do-syntax-ize (shaped-parens-val v) col line ht #f qq #f)
|
||||||
'paren-shape
|
'paren-shape
|
||||||
(shaped-parens-shape v))]
|
(shaped-parens-shape v))]
|
||||||
[(just-context? v)
|
[(just-context? v)
|
||||||
(let ([s (do-syntax-ize (just-context-val v) col line ht #f qq)])
|
(let ([s (do-syntax-ize (just-context-val v) col line ht #f qq #f)])
|
||||||
(datum->syntax (just-context-ctx v)
|
(datum->syntax (just-context-ctx v)
|
||||||
(syntax-e s)
|
(syntax-e s)
|
||||||
s
|
s
|
||||||
s
|
s
|
||||||
(just-context-ctx v)))]
|
(just-context-ctx v)))]
|
||||||
[(alternate-display? v)
|
[(alternate-display? v)
|
||||||
(let ([s (do-syntax-ize (alternate-display-id v) col line ht #f qq)])
|
(let ([s (do-syntax-ize (alternate-display-id v) col line ht #f qq #f)])
|
||||||
(syntax-property s
|
(syntax-property s
|
||||||
'display-string
|
'display-string
|
||||||
(alternate-display-string v)))]
|
(alternate-display-string v)))]
|
||||||
|
|
@ -924,30 +1028,49 @@
|
||||||
(datum->syntax #f
|
(datum->syntax #f
|
||||||
(make-graph-reference m)
|
(make-graph-reference m)
|
||||||
(vector #f line col (+ 1 col) 1)))]
|
(vector #f line col (+ 1 col) 1)))]
|
||||||
|
[(and qq
|
||||||
|
(zero? qq)
|
||||||
|
(or (pair? v)
|
||||||
|
(forced-pair? v)
|
||||||
|
(vector? v)
|
||||||
|
(hash? v)
|
||||||
|
(box? v)
|
||||||
|
(and (struct? v)
|
||||||
|
(prefab-struct-key v)))
|
||||||
|
(quotable? v)
|
||||||
|
(not no-cons?))
|
||||||
|
;; Add a quote:
|
||||||
|
(let ([l (do-syntax-ize v (add1 col) line ht #f 1 #f)])
|
||||||
|
(datum->syntax #f
|
||||||
|
(syntax-e l)
|
||||||
|
(vector (syntax-source l)
|
||||||
|
(syntax-line l)
|
||||||
|
(sub1 (syntax-column l))
|
||||||
|
(max 0 (sub1 (syntax-position l)))
|
||||||
|
(add1 (syntax-span l)))))]
|
||||||
[(and (list? v)
|
[(and (list? v)
|
||||||
(pair? v)
|
(pair? v)
|
||||||
|
(or (not qq)
|
||||||
|
(positive? qq)
|
||||||
|
(quotable? v))
|
||||||
(let ([s (let ([s (car v)])
|
(let ([s (let ([s (car v)])
|
||||||
(if (just-context? s)
|
(if (just-context? s)
|
||||||
(just-context-val s)
|
(just-context-val s)
|
||||||
s))])
|
s))])
|
||||||
(and
|
(memq s '(quote unquote unquote-splicing)))
|
||||||
(or (memq s '(quaisquote quote))
|
(not no-cons?))
|
||||||
(and (memq s '(unquote unquote-splicing))
|
|
||||||
(or (not qq)
|
|
||||||
(qq . > . 2))))
|
|
||||||
s)))
|
|
||||||
=> (lambda (s)
|
=> (lambda (s)
|
||||||
(let ([c (do-syntax-ize (cadr v) (+ col 1) line ht #f qq)])
|
(let* ([delta (if (and qq (zero? qq))
|
||||||
|
1
|
||||||
|
0)]
|
||||||
|
[c (do-syntax-ize (cadr v) (+ col delta) line ht #f qq #f)])
|
||||||
(datum->syntax #f
|
(datum->syntax #f
|
||||||
(list (do-syntax-ize (car v) col line ht #f
|
(list (do-syntax-ize (car v) col line ht #f qq #f)
|
||||||
(and qq
|
|
||||||
(case s
|
|
||||||
[(quaisquote) (add1 qq)]
|
|
||||||
[(unquote unquote-splicing) (sub1 qq)]
|
|
||||||
[else qq])))
|
|
||||||
c)
|
c)
|
||||||
(vector #f line col (+ 1 col)
|
(vector #f line col (+ 1 col)
|
||||||
(+ 1 (syntax-span c))))))]
|
(+ 1
|
||||||
|
(if (and qq (zero? qq)) 1 0)
|
||||||
|
(syntax-span c))))))]
|
||||||
[(or (list? v)
|
[(or (list? v)
|
||||||
(vector? v)
|
(vector? v)
|
||||||
(and (struct? v)
|
(and (struct? v)
|
||||||
|
|
@ -956,21 +1079,28 @@
|
||||||
(not (element? v)))
|
(not (element? v)))
|
||||||
(prefab-struct-key v))))
|
(prefab-struct-key v))))
|
||||||
(let ([orig-ht (unbox ht)]
|
(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))
|
(set-box! ht (hash-set (unbox ht) v graph-box))
|
||||||
(let* ([graph-sz (if graph?
|
(let* ([graph-sz (if graph?
|
||||||
(+ 2 (string-length (format "~a" (unbox graph-box))))
|
(+ 2 (string-length (format "~a" (unbox graph-box))))
|
||||||
0)]
|
0)]
|
||||||
[vec-sz (cond
|
[vec-sz (cond
|
||||||
[(vector? v)
|
[(vector? v)
|
||||||
(+ 1 #;(string-length (format "~a" (vector-length v))))]
|
(if (and qq (zero? qq)) 0 1)]
|
||||||
[(struct? v)
|
[(struct? v)
|
||||||
(if (prefab-struct-key v)
|
(if (and (prefab-struct-key v)
|
||||||
|
(or (not qq) (positive? qq)))
|
||||||
2
|
2
|
||||||
0)]
|
0)]
|
||||||
[else 0])]
|
[else 0])]
|
||||||
[r (let ([l (let loop ([col (+ col 1 vec-sz graph-sz)]
|
[delta (if (and qq (zero? qq))
|
||||||
|
(cond
|
||||||
|
[(vector? v) 8]
|
||||||
|
[(struct? v) 1]
|
||||||
|
[no-cons? 1]
|
||||||
|
[else 5])
|
||||||
|
1)]
|
||||||
|
[r (let ([l (let loop ([col (+ col delta vec-sz graph-sz)]
|
||||||
[v (cond
|
[v (cond
|
||||||
[(vector? v)
|
[(vector? v)
|
||||||
(vector->short-list v values)]
|
(vector->short-list v values)]
|
||||||
|
|
@ -983,7 +1113,7 @@
|
||||||
[else v])])
|
[else v])])
|
||||||
(if (null? v)
|
(if (null? v)
|
||||||
null
|
null
|
||||||
(let ([i (do-syntax-ize (car v) col line ht #f qq)])
|
(let ([i (do-syntax-ize (car v) col line ht #f qq #f)])
|
||||||
(cons i
|
(cons i
|
||||||
(loop (+ col 1 (syntax-span i)) (cdr v))))))])
|
(loop (+ col 1 (syntax-span i)) (cdr v))))))])
|
||||||
(datum->syntax #f
|
(datum->syntax #f
|
||||||
|
|
@ -998,8 +1128,9 @@
|
||||||
(vector #f line
|
(vector #f line
|
||||||
(+ graph-sz col)
|
(+ graph-sz col)
|
||||||
(+ 1 graph-sz col)
|
(+ 1 graph-sz col)
|
||||||
(+ 2
|
(+ 1
|
||||||
vec-sz
|
vec-sz
|
||||||
|
delta
|
||||||
(if (zero? (length l))
|
(if (zero? (length l))
|
||||||
0
|
0
|
||||||
(sub1 (length l)))
|
(sub1 (length l)))
|
||||||
|
|
@ -1016,55 +1147,85 @@
|
||||||
[(unbox graph-box)
|
[(unbox graph-box)
|
||||||
;; Go again, this time knowing that there will be a graph:
|
;; Go again, this time knowing that there will be a graph:
|
||||||
(set-box! ht orig-ht)
|
(set-box! ht orig-ht)
|
||||||
(do-syntax-ize v col line ht #t qq)]
|
(do-syntax-ize v col line ht #t qq #f)]
|
||||||
[else r])))]
|
[else r])))]
|
||||||
[(or (pair? v)
|
[(or (pair? v)
|
||||||
|
(mpair? v)
|
||||||
(forced-pair? v))
|
(forced-pair? v))
|
||||||
(let ([carv (if (pair? v) (car v) (forced-pair-car v))]
|
(let ([carv (if (pair? v) (car v) (if (mpair? v) (mcar v) (forced-pair-car v)))]
|
||||||
[cdrv (if (pair? v) (cdr v) (forced-pair-cdr v))]
|
[cdrv (if (pair? v) (cdr v) (if (mpair? v) (mcdr v) (forced-pair-cdr v)))]
|
||||||
[orig-ht (unbox ht)]
|
[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))
|
(set-box! ht (hash-set (unbox ht) v graph-box))
|
||||||
(let* ([inc (if graph?
|
(let* ([delta (if (and qq (zero? qq) (not no-cons?))
|
||||||
|
(if (mpair? v)
|
||||||
|
7 ; "(mcons "
|
||||||
|
(if (or (list? cdrv)
|
||||||
|
(not (pair? cdrv)))
|
||||||
|
6 ; "(cons "
|
||||||
|
7)) ; "(list* "
|
||||||
|
1)]
|
||||||
|
[inc (if graph?
|
||||||
(+ 2 (string-length (format "~a" (unbox graph-box))))
|
(+ 2 (string-length (format "~a" (unbox graph-box))))
|
||||||
0)]
|
0)]
|
||||||
[a (do-syntax-ize carv (+ col 1 inc) line ht #f qq)]
|
[a (do-syntax-ize carv (+ col delta inc) line ht #f qq #f)]
|
||||||
[sep (if (and (pair? v)
|
[sep (if (and (pair? v)
|
||||||
(pair? cdrv)
|
(pair? cdrv)
|
||||||
;; FIXME: what if it turns out to be a graph reference?
|
;; FIXME: what if it turns out to be a graph reference?
|
||||||
(not (hash-ref (unbox ht) cdrv #f)))
|
(not (hash-ref (unbox ht) cdrv #f)))
|
||||||
0
|
0
|
||||||
3)]
|
(if (and qq (zero? qq))
|
||||||
[b (do-syntax-ize cdrv (+ col 1 inc (syntax-span a) sep) line ht #f qq)])
|
1
|
||||||
|
3))]
|
||||||
|
[b (do-syntax-ize cdrv (+ col delta inc (syntax-span a) sep) line ht #f qq #t)])
|
||||||
(let ([r (datum->syntax #f
|
(let ([r (datum->syntax #f
|
||||||
(cons a b)
|
(if (mpair? v)
|
||||||
(vector #f line (+ col inc) (+ 1 col inc)
|
(mcons a b)
|
||||||
(+ 2 sep (syntax-span a) (syntax-span b))))])
|
(cons a b))
|
||||||
|
(vector #f line (+ col inc) (+ delta col inc)
|
||||||
|
(+ 1 delta
|
||||||
|
(if (and qq (zero? qq)) 1 0)
|
||||||
|
sep (syntax-span a) (syntax-span b))))])
|
||||||
(unless graph?
|
(unless graph?
|
||||||
(set-box! ht (hash-set (unbox ht) v #f)))
|
(set-box! ht (hash-set (unbox ht) v #f)))
|
||||||
(cond
|
(cond
|
||||||
[graph? (datum->syntax #f
|
[graph? (datum->syntax #f
|
||||||
(make-graph-defn r graph-box)
|
(make-graph-defn r graph-box)
|
||||||
(vector #f line col (+ 1 col)
|
(vector #f line col (+ delta col)
|
||||||
(+ inc (syntax-span r))))]
|
(+ inc (syntax-span r))))]
|
||||||
[(unbox graph-box)
|
[(unbox graph-box)
|
||||||
;; Go again...
|
;; Go again...
|
||||||
(set-box! ht orig-ht)
|
(set-box! ht orig-ht)
|
||||||
(do-syntax-ize v col line ht #t qq)]
|
(do-syntax-ize v col line ht #t qq #f)]
|
||||||
[else r]))))]
|
[else r]))))]
|
||||||
[(box? v)
|
[(box? v)
|
||||||
(let ([a (do-syntax-ize (unbox v) (+ col 2) line ht #f (and qq (max 1 qq)))])
|
(let* ([delta (if (and qq (zero? qq))
|
||||||
|
5 ; "(box "
|
||||||
|
2)] ; "#&"
|
||||||
|
[a (do-syntax-ize (unbox v) (+ col delta) line ht #f qq #f)])
|
||||||
(datum->syntax #f
|
(datum->syntax #f
|
||||||
(box a)
|
(box a)
|
||||||
(vector #f line col (+ 1 col)
|
(vector #f line col (+ 1 col)
|
||||||
(+ 2 (syntax-span a)))))]
|
(+ delta (if (and qq (zero? qq)) 1 0) (syntax-span a)))))]
|
||||||
[(hash? v)
|
[(hash? v)
|
||||||
(let* ([delta (cond
|
(let* ([delta (cond
|
||||||
[(hash-eq? v) 7]
|
[(hash-eq? v) 7]
|
||||||
[(hash-eqv? v) 8]
|
[(hash-eqv? v) 8]
|
||||||
[else 6])]
|
[else 6])]
|
||||||
[pairs (do-syntax-ize (hash-map v make-forced-pair) (+ col delta) line ht #f (and qq (max 1 qq)))])
|
[undelta (if (and qq (zero? qq))
|
||||||
|
(- delta 1)
|
||||||
|
0)]
|
||||||
|
[pairs (if (and qq (zero? qq))
|
||||||
|
(let ([ls (do-syntax-ize (apply append (hash-map v (lambda (k v) (list k v))))
|
||||||
|
(+ col delta -1) line ht #f qq #t)])
|
||||||
|
(datum->syntax
|
||||||
|
#f
|
||||||
|
(let loop ([l (syntax->list ls)])
|
||||||
|
(if (null? l)
|
||||||
|
null
|
||||||
|
(cons (cons (car l) (cadr l)) (loop (cddr l)))))
|
||||||
|
ls))
|
||||||
|
(do-syntax-ize (hash-map v make-forced-pair) (+ col delta) line ht #f qq #f))])
|
||||||
(datum->syntax #f
|
(datum->syntax #f
|
||||||
((cond
|
((cond
|
||||||
[(hash-eq? v) make-immutable-hasheq]
|
[(hash-eq? v) make-immutable-hasheq]
|
||||||
|
|
@ -1075,6 +1236,10 @@
|
||||||
(cons (syntax->datum (car p))
|
(cons (syntax->datum (car p))
|
||||||
(cdr p))))
|
(cdr p))))
|
||||||
(syntax->list pairs)))
|
(syntax->list pairs)))
|
||||||
pairs))]
|
(vector (syntax-source pairs)
|
||||||
|
(syntax-line pairs)
|
||||||
|
(max 0 (- (syntax-column pairs) undelta))
|
||||||
|
(max 1 (- (syntax-position pairs) undelta))
|
||||||
|
(+ (syntax-span pairs) undelta))))]
|
||||||
[else
|
[else
|
||||||
(datum->syntax #f v (vector #f line col (+ 1 col) 1))])))
|
(datum->syntax #f v (vector #f line col (+ 1 col) 1))])))
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user