Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 13:49:17 +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

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

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

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

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

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

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