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

better fix for #618

Browse source
This commit is contained in:
Alex Shinn 2020-06-16 10:05:26 +09:00
parent d511b8e31d
commit 23f93cceb4
2 changed files with 62 additions and 57 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

110
lib/srfi/38.scm
View file

@ -66,62 +66,60 @@
(set! count (+ count 1))))
(cont x index)))))
(let wr ((x x))
(check-shared
x
""
(lambda (x shared?)
(cond
((pair? x)
(display "(" out)
(wr (car x))
(let lp ((ls (cdr x)))
(check-shared
ls
" . "
(lambda (ls shared?)
(cond ((null? ls))
((pair? ls)
(cond
(shared?
(display "(" out)
(wr (car ls))
(check-shared
(cdr ls)
" . "
(lambda (ls shared?) (lp ls)))
(display ")" out))
(else
(display " " out)
(wr (car ls))
(lp (cdr ls)))))
(shared? ;; shared dotted tail
(write ls out))
(else
(display " . " out)
(wr ls))))))
(display ")" out))
((vector? x)
(display "#(" out)
(let ((len (vector-length x)))
(cond ((> len 0)
(wr (vector-ref x 0))
(do ((i 1 (+ i 1)))
((= i len))
(display " " out)
(wr (vector-ref x i))))))
(display ")" out))
((let ((type (type-of x)))
(and (type? type) (type-printer type)))
=> (lambda (printer) (printer x wr out)))
((null? x) (display "()" out))
((char? x) (display "#\\" out) (write-char x out))
((symbol? x) (write x out))
((number? x) (display (number->string x) out))
((eq? x #t) (display "#t" out))
((eq? x #f) (display "#f" out))
(else
;; (display "#<unknown>" out)
(write x out))))))))
(define (wr-one x shared?)
(cond
((pair? x)
(display "(" out)
(wr (car x))
(let lp ((ls (cdr x)))
(check-shared
ls
" . "
(lambda (ls shared?)
(cond ((null? ls))
((pair? ls)
(cond
(shared?
(display "(" out)
(wr (car ls))
(check-shared
(cdr ls)
" . "
(lambda (ls shared?) (lp ls)))
(display ")" out))
(else
(display " " out)
(wr (car ls))
(lp (cdr ls)))))
(shared? ;; shared dotted tail
(wr-one ls #f))
(else
(display " . " out)
(wr ls))))))
(display ")" out))
((vector? x)
(display "#(" out)
(let ((len (vector-length x)))
(cond ((> len 0)
(wr (vector-ref x 0))
(do ((i 1 (+ i 1)))
((= i len))
(display " " out)
(wr (vector-ref x i))))))
(display ")" out))
((let ((type (type-of x)))
(and (type? type) (type-printer type)))
=> (lambda (printer) (printer x wr out)))
((null? x) (display "()" out))
((char? x) (display "#\\" out) (write-char x out))
((symbol? x) (write x out))
((number? x) (display (number->string x) out))
((eq? x #t) (display "#t" out))
((eq? x #f) (display "#f" out))
(else
;; (display "#<unknown>" out)
(write x out))))
(check-shared x "" wr-one))))
(define write/ss write-with-shared-structure)

9
lib/srfi/38/test.sld
View file

@ -21,7 +21,7 @@
(define-syntax test-cyclic-io
(syntax-rules ()
((test-io str-expr expr)
((test-cyclic-io str-expr expr)
(let ((str str-expr)
(value expr))
(test str (write-to-string value #t))
@ -48,6 +48,13 @@
(test-io "(#0=(1 . 2) #1=(1 . 2) #2=(3 . 4) #0# #1# #2#)"
(let ((a (cons 1 2)) (b (cons 1 2)) (c (cons 3 4)))
(list a b c a b c)))
(test-io "((1 . #0=#(2)) #0#)"
(let ((vec (vector 2)))
(list (cons 1 vec) vec)))
(test-io "((1 . #0=#(2 #0#)) #0#)"
(let ((vec (vector 2 #f)))
(vector-set! vec 1 vec)
(list (cons 1 vec) vec)))
(test-cyclic-io "((1 . 2) (1 . 2) (3 . 4) (1 . 2) (1 . 2) (3 . 4))"
(let ((a (cons 1 2)) (b (cons 1 2)) (c (cons 3 4)))
(list a b c a b c)))