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

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

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

@ -21,7 +21,7 @@
(define-syntax test-cyclic-io (define-syntax test-cyclic-io
(syntax-rules () (syntax-rules ()
((test-io str-expr expr) ((test-cyclic-io str-expr expr)
(let ((str str-expr) (let ((str str-expr)
(value expr)) (value expr))
(test str (write-to-string value #t)) (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#)" (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))) (let ((a (cons 1 2)) (b (cons 1 2)) (c (cons 3 4)))
(list a b c a b c))) (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))" (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))) (let ((a (cons 1 2)) (b (cons 1 2)) (c (cons 3 4)))
(list a b c a b c))) (list a b c a b c)))