Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-18 21:29:19 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

fixing pretty-printed circular lists

Browse source
This commit is contained in:
Alex Shinn 2020-07-20 16:38:48 +09:00
parent 7366a13413
commit bcbed04b3b
4 changed files with 65 additions and 51 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

25
lib/chibi/show/shared.sld
View file

@ -39,20 +39,21 @@
(set! count (+ count 1))))))
(cons res 0))))
(define (maybe-gen-shared-ref cell shares)
(cond
((pair? cell)
(set-car! cell (cdr shares))
(set-cdr! cell #t)
(set-cdr! shares (+ (cdr shares) 1))
(string-append "#" (number->string (car cell)) "="))
(else "")))
(define (gen-shared-ref cell shares)
(set-car! cell (cdr shares))
(set-cdr! cell #t)
(set-cdr! shares (+ (cdr shares) 1))
(string-append (number->string (car cell))))
(define (call-with-shared-ref obj shares each proc)
(let ((cell (hash-table-ref/default (car shares) obj #f)))
(if (and (pair? cell) (cdr cell))
(each "#" (number->string (car cell)) "#")
(each (maybe-gen-shared-ref cell shares) proc))))
(cond
((and (pair? cell) (cdr cell))
(each "#" (number->string (car cell)) "#"))
((pair? cell)
(each "#" (gen-shared-ref cell shares) "=" proc))
(else
(each proc)))))
(define (call-with-shared-ref/cdr obj shares each proc . o)
(let ((sep (if (pair? o) (car o) ""))
@ -61,7 +62,7 @@
((and (pair? cell) (cdr cell))
(each sep ". #" (number->string (car cell)) "#"))
((pair? cell)
(each sep ". " (maybe-gen-shared-ref cell shares) "(" proc ")"))
(each sep ". #" (gen-shared-ref cell shares) "=(" proc ")"))
(else
(each sep proc)))))
))

21
lib/srfi/166/column.scm
View file

@ -237,15 +237,18 @@
(width #t) (border-width 0) (res '()))
(cond
((null? ls)
(if (pair? strs)
(finish (cons (cons (caar res)
(cons #t (cons (append (reverse strs)
(cadr (cdar res)))
(cddr (cdar res)))))
(cdr res))
border-width)
(finish (cons (cons (caar res) (cons #t (cddr (car res)))) (cdr res))
border-width)))
(cond
((null? res) nl)
((pair? strs)
(finish (cons (cons (caar res)
(cons #t (cons (append (reverse strs)
(cadr (cdar res)))
(cddr (cdar res)))))
(cdr res))
border-width))
(else
(finish (cons (cons (caar res) (cons #t (cddr (car res)))) (cdr res))
border-width))))
((char? (car ls))
(lp (cons (string (car ls)) (cdr ls)) strs align infinite?
width border-width res))

68
lib/srfi/166/pretty.scm
View file

@ -28,8 +28,11 @@
(define (joined/shares fmt ls shares . o)
(let ((sep (displayed (if (pair? o) (car o) " "))))
(fn ()
(if (null? ls)
nothing
(cond
((null? ls)
nothing)
((pair? ls)
(fn ()
(let lp ((ls ls))
(each
(fmt (car ls))
@ -42,7 +45,8 @@
each
(fn () (lp rest))
sep))
(else (each sep ". " (fmt rest)))))))))))
(else (each sep ". " (fmt rest)))))))))
(else (fmt ls))))))
(define (string-find/index str pred i)
(string-cursor->index
@ -182,14 +186,13 @@
(let ((orig-count (cdr shares)))
(fn ()
(let ((new-count (cdr shares)))
(cond
((> new-count orig-count)
(when (> new-count orig-count)
(hash-table-walk
(car shares)
(lambda (k v)
(if (and (cdr v) (>= (car v) orig-count))
(set-cdr! v #f))))
(set-cdr! shares orig-count)))
(set-cdr! shares orig-count))
proc))))
(define (pp-with-indent indent-rule ls pp shares color?)
@ -203,12 +206,12 @@
(tail (drop* (cdr ls) (or indent-rule 1)))
(default
(let ((sep (make-nl-space (+ col1 1))))
(each sep (joined/shares pp (cdr ls) shares sep))))
(fn () (each sep (joined/shares pp (cdr ls) shares sep)))))
;; reset in case we don't fit on the first line
(reset-shares (with-reset-shares shares nothing)))
(call-with-output
(trimmed/lazy (- width col2)
(each " "
(each (if (or (null? fixed) (pair? fixed)) " " " . ")
(joined/shares
(lambda (x) (pp-flat x pp shares color?))
fixed shares " ")))
@ -322,12 +325,23 @@
each
(pp-flat (cadr x) pp shares color?)))))
(else
(each "("
((if (and color? (memq (car x) pp-macros)) as-blue displayed)
(pp (car x)))
" "
(joined/shares ppf (cdr x) shares " ")
")"))))
(fn ()
(each "("
((if (and color? (memq (car x) pp-macros)) as-blue displayed)
(pp (car x)))
(if (null? (cdr x))
nothing
(call-with-shared-ref/cdr
(cdr x)
shares
each
(cond
((pair? (cdr x))
(each "" (joined/shares ppf (cdr x) shares " ")))
(else
(each ". " (joined/shares ppf (cdr x) shares " "))))
" "))
")")))))
((vector? x)
(each "#("
(joined/shares ppf (vector->list x) shares " ")
@ -346,22 +360,16 @@
=> (lambda (abbrev)
(each (cdr abbrev) (pp (cadr ls)))))
(else
(try-fitted
(pp-flat ls pp shares color?)
;; (fn ()
;; (each "("
;; ((if (and color? (memq (car ls) pp-macros)) as-blue displayed)
;; (pp (car ls)))
;; " "
;; (joined/shares (lambda (x) (pp-flat x pp shares)) (cdr ls) shares " ")
;; ")"))
(with-reset-shares
shares
(fn ()
(if (and (non-app? ls)
(proper-non-shared-list? ls shares))
(pp-data-list ls pp shares)
(pp-app ls pp shares color?))))))))
(let ((reset-shares (with-reset-shares shares nothing)))
(try-fitted
(pp-flat ls pp shares color?)
(each
reset-shares
(fn ()
(if (and (non-app? ls)
(proper-non-shared-list? ls shares))
(pp-data-list ls pp shares)
(pp-app ls pp shares color?)))))))))
(define (pp-vector vec pp shares)
(each "#" (pp-data-list (vector->list vec) pp shares)))

2
tests/lib-tests.scm
View file

@ -32,6 +32,7 @@
(rename (srfi 151 test) (run-tests run-srfi-151-tests))
(rename (srfi 158 test) (run-tests run-srfi-158-tests))
(rename (srfi 160 test) (run-tests run-srfi-160-tests))
(rename (srfi 166 test) (run-tests run-srfi-166-tests))
(rename (scheme bytevector-test) (run-tests run-scheme-bytevector-tests))
(rename (chibi base64-test) (run-tests run-base64-tests))
(rename (chibi bytevector-test) (run-tests run-bytevector-tests))
@ -99,6 +100,7 @@
(run-srfi-151-tests)
(run-srfi-158-tests)
(run-srfi-160-tests)
(run-srfi-166-tests)
(run-scheme-bytevector-tests)
(run-base64-tests)
(run-bytevector-tests)