suzanne.soy/scribble-enhanced
1
0
Fork 0
Code Issues 1 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

shared

Browse Source 
svn: r8069

original commit: f70ea2d03aea2e5c74536d1f64d1df023090432a
This commit is contained in:
Matthew Flatt 2007-12-19 21:32:07 +00:00
parent c46667ae55
commit 5ec968d86f
2 changed files with 117 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/scribble/eval.ss
View File

@ -141,7 +141,7 @@
(get-output-string o) (get-output-string o)
(get-output-string o2)))]) (get-output-string o2)))])
(list (let ([v (do-plain-eval s #t)]) (list (let ([v (do-plain-eval s #t)])
(copy-value v (make-hash-table))) (make-reader-graph (copy-value v (make-hash-table))))
(get-output-string o) (get-output-string o)
(get-output-string o2)))))])) (get-output-string o2)))))]))
@ -157,9 +157,15 @@
=> (lambda (v) v)] => (lambda (v) v)]
[(string? v) (install ht v (string-copy v))] [(string? v) (install ht v (string-copy v))]
[(bytes? v) (install ht v (bytes-copy v))] [(bytes? v) (install ht v (bytes-copy v))]
[(pair? v) (cons (copy-value (car v) ht) [(pair? v)
(copy-value (cdr v) ht))] (let ([ph (make-placeholder #f)])
(hash-table-put! ht v ph)
(placeholder-set! ph
(cons (copy-value (car v) ht)
(copy-value (cdr v) ht)))
ph)]
[(mpair? v) (let ([p (mcons #f #f)]) [(mpair? v) (let ([p (mcons #f #f)])
(hash-table-put! ht v p)
(set-mcar! p (copy-value (mcar v) ht)) (set-mcar! p (copy-value (mcar v) ht))
(set-mcdr! p (copy-value (mcdr v) ht)) (set-mcdr! p (copy-value (mcdr v) ht))
p)] p)]

145
collects/scribble/scheme.ss
View File

@ -390,7 +390,6 @@
((loop init-line! quote-depth) (car l)) ((loop init-line! quote-depth) (car l))
(lloop (cdr l))] (lloop (cdr l))]
[else [else
(advance l init-line! -2) (advance l init-line! -2)
(out ". " (if (positive? quote-depth) value-color paren-color)) (out ". " (if (positive? quote-depth) value-color paren-color))
(set! src-col (+ src-col 3)) (set! src-col (+ src-col 3))
@ -425,6 +424,20 @@
(syntax-ize (hash-table-map (syntax-e c) cons) (syntax-ize (hash-table-map (syntax-e c) cons)
(+ (syntax-column c) delta))) (+ (syntax-column c) delta)))
(set! src-col (+ orig-col (syntax-span c)))))] (set! src-col (+ orig-col (syntax-span c)))))]
[(graph-reference? (syntax-e c))
(out (format "#~a#" (unbox (graph-reference-bx (syntax-e c))))
(if (positive? quote-depth)
value-color
paren-color))]
[(graph-defn? (syntax-e c))
(let ([bx (graph-defn-bx (syntax-e c))])
(set-box! bx 0)
(out (format "#~a=" (unbox bx))
(if (positive? quote-depth)
value-color
paren-color))
(set! src-col (+ src-col 3))
((loop init-line! quote-depth) (graph-defn-r (syntax-e c))))]
[else [else
(advance c init-line!) (advance c init-line!)
(typeset-atom c out color? quote-depth) (typeset-atom c out color? quote-depth)
@ -458,7 +471,9 @@
(vector? s) (vector? s)
(box? s) (box? s)
(null? s) (null? s)
(hash-table? s)) (hash-table? 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?)
(typeset-atom c (typeset-atom c
(case-lambda (case-lambda
@ -561,6 +576,8 @@
(define syntax-ize-hook (make-parameter (lambda (v col) #f))) (define syntax-ize-hook (make-parameter (lambda (v col) #f)))
(define (vector->short-list v extract) (define (vector->short-list v extract)
(vector->list v)
#;
(let ([l (vector->list v)]) (let ([l (vector->list v)])
(reverse (list-tail (reverse (list-tail
(reverse l) (reverse l)
@ -586,21 +603,40 @@
(define-struct shaped-parens (val shape)) (define-struct shaped-parens (val shape))
(define-struct just-context (val ctx)) (define-struct just-context (val ctx))
(define-struct graph-reference (bx))
(define-struct graph-defn (r bx))
(define (syntax-ize v col) (define (syntax-ize v col)
(do-syntax-ize v col (make-hash-table) #f))
(define (graph-count ht graph?)
(and graph?
(let ([n (hash-table-get ht '#%graph-count 0)])
(hash-table-put! ht '#%graph-count (add1 n))
n)))
(define (do-syntax-ize v col ht graph?)
(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 (syntax-ize (shaped-parens-val v) col) (syntax-property (do-syntax-ize (shaped-parens-val v) col ht #f)
'paren-shape 'paren-shape
(shaped-parens-shape v))] (shaped-parens-shape v))]
[(just-context? v) [(just-context? v)
(let ([s (syntax-ize (just-context-val v) col)]) (let ([s (do-syntax-ize (just-context-val v) col ht #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)))]
[(hash-table-get ht v #f)
=> (lambda (m)
(unless (unbox m)
(set-box! m #t))
(datum->syntax #f
(make-graph-reference m)
(list #f 1 col (+ 1 col) 1)))]
[(and (list? v) [(and (list? v)
(pair? v) (pair? v)
(memq (let ([s (car v)]) (memq (let ([s (car v)])
@ -608,47 +644,82 @@
(just-context-val s) (just-context-val s)
s)) s))
'(quote unquote unquote-splicing))) '(quote unquote unquote-splicing)))
(let ([c (syntax-ize (cadr v) (+ col 1))]) (let ([c (do-syntax-ize (cadr v) (+ col 1) ht #f)])
(datum->syntax #f (datum->syntax #f
(list (syntax-ize (car v) col) (list (do-syntax-ize (car v) col ht #f)
c) c)
(list #f 1 col (+ 1 col) (list #f 1 col (+ 1 col)
(+ 1 (syntax-span c)))))] (+ 1 (syntax-span c)))))]
[(or (list? v) [(or (list? v)
(vector? v)) (vector? v))
(let* ([vec-sz (if (vector? v) (let ([graph-box (box (graph-count ht graph?))])
(+ 1 #;(string-length (format "~a" (vector-length v)))) (hash-table-put! ht v graph-box)
0)]) (let ([r (let* ([vec-sz (+ (if graph?
(let ([l (let loop ([col (+ col 1 vec-sz)] (+ 2 (string-length (format "~a" (unbox graph-box))))
[v (if (vector? v) 0)
(vector->short-list v values) (if (vector? v)
v)]) (+ 1 #;(string-length (format "~a" (vector-length v))))
(if (null? v) 0))])
null (let ([l (let loop ([col (+ col 1 vec-sz)]
(let ([i (syntax-ize (car v) col)]) [v (if (vector? v)
(cons i (vector->short-list v values)
(loop (+ col 1 (syntax-span i)) (cdr v))))))]) v)])
(datum->syntax #f (if (null? v)
(if (vector? v) null
(short-list->vector v l) (let ([i (do-syntax-ize (car v) col ht #f)])
l) (cons i
(list #f 1 col (+ 1 col) (loop (+ col 1 (syntax-span i)) (cdr v))))))])
(+ 2 (datum->syntax #f
vec-sz (if (vector? v)
(if (zero? (length l)) (short-list->vector v l)
0 l)
(sub1 (length l))) (list #f 1 col (+ 1 col)
(apply + (map syntax-span l)))))))] (+ 2
vec-sz
(if (zero? (length l))
0
(sub1 (length l)))
(apply + (map syntax-span l)))))))])
(unless graph?
(hash-table-put! ht v #f))
(cond
[graph? (datum->syntax #f
(make-graph-defn r graph-box)
r)]
[(unbox graph-box)
;; Go again, this time knowing that there will be a graph:
(do-syntax-ize v col ht #t)]
[else r])))]
[(pair? v) [(pair? v)
(let* ([a (syntax-ize (car v) (+ col 1))] (let ([graph-box (box (graph-count ht graph?))])
[sep (if (pair? (cdr v)) 0 3)] (hash-table-put! ht v graph-box)
[b (syntax-ize (cdr v) (+ col 1 (syntax-span a) sep))]) (let* ([inc (if graph?
(datum->syntax #f (+ 2 (string-length (format "~a" (unbox graph-box))))
(cons a b) 0)]
(list #f 1 col (+ 1 col) [a (do-syntax-ize (car v) (+ col 1 inc) ht #f)]
(+ 2 sep (syntax-span a) (syntax-span b)))))] [sep (if (and (pair? (cdr v))
;; FIXME: what if it turns out to be a graph reference?
(not (hash-table-get ht (cdr v) #f)))
0
3)]
[b (do-syntax-ize (cdr v) (+ col 1 inc (syntax-span a) sep) ht #f)])
(let ([r (datum->syntax #f
(cons a b)
(list #f 1 (+ col inc) (+ 1 col inc)
(+ 2 sep (syntax-span a) (syntax-span b))))])
(unless graph?
(hash-table-put! ht v #f))
(cond
[graph? (datum->syntax #f
(make-graph-defn r graph-box)
(list #f 1 col (+ 1 col)
(+ inc (syntax-span r))))]
[(unbox graph-box)
;; Go again...
(do-syntax-ize v col ht #t)]
[else r]))))]
[(box? v) [(box? v)
(let ([a (syntax-ize (unbox v) (+ col 2))]) (let ([a (do-syntax-ize (unbox v) (+ col 2) ht #f)])
(datum->syntax #f (datum->syntax #f
(box a) (box a)
(list #f 1 col (+ 1 col) (list #f 1 col (+ 1 col)