1: ;; test for write/ss and read/ss
    2: ;;
    3: ;; this test is splitted from io.scm, since this one uses util.isomorph,
    4: ;; and has to be done after the test of util.* module.
    5: 
    6: ;; $Id: io2.scm,v 1.4 2006/10/08 03:59:42 shirok Exp $
    7: 
    8: (use gauche.test)
    9: (use srfi-1)
   10: (use util.isomorph)
   11: 
   12: (test-start "write/ss and read/ss")
   13: 
   14: ;;---------------------------------------------------------------
   15: (test-section "write/ss basic")
   16: 
   17: (test* "pair" "(#0=(a b) #0#)"
   18:        (let1 x '(a b)
   19:          (write-to-string (list x x) write/ss)))
   20: (test* "pair" "(#0=(a b) . #0#)"
   21:        (let1 x (list 'a 'b)
   22:          (write-to-string (cons x x) write/ss)))
   23: (test* "pair" "(#0=(a b) #1=(a b) #0# . #1#)"
   24:        (let ((x (list 'a 'b))
   25:              (y (list 'a 'b)))
   26:          (write-to-string (list* x y x y) write/ss)))
   27: (test* "pair (circular)" "#0=(a . #0#)"
   28:        (let1 x (list 'a 'b)
   29:          (set-cdr! x x)
   30:          (write-to-string x write/ss)))
   31: (test* "pair (circular)" "#0=(#0# b)"
   32:        (let1 x (list 'a 'b)
   33:          (set-car! x x)
   34:          (write-to-string x write/ss)))
   35: (test* "pair (circular)" "#0=(#0# . #0#)"
   36:        (let1 x (list 'a 'b)
   37:          (set-car! x x)
   38:          (set-cdr! x x)
   39:          (write-to-string x write/ss)))
   40: (test* "pair (circular)" "#0=(a (b . #0#))"
   41:        (let1 x (list 'a (list 'b 'c))
   42:          (set-cdr! (cadr x) x)
   43:          (write-to-string x write/ss)))
   44: (test* "pair (circular)" "#0=(a #1=(b . #0#) . #1#)"
   45:        (let1 x (list 'a (list 'b 'c))
   46:          (set-cdr! (cadr x) x)
   47:          (set-cdr! (cdr x) (cadr x))
   48:          (write-to-string x write/ss)))
   49: 
   50: (test* "vector" "(#0=#(a b) . #0#)"
   51:        (let1 x (vector 'a 'b)
   52:          (write-to-string (cons x x) write/ss)))
   53: (test* "vector" "(#() . #())"
   54:        (let1 x (vector)
   55:          (write-to-string (cons x x) write/ss)))
   56: (test* "vector" "#(#0=(a b) #0# #0#)"
   57:        (let1 x '(a b)
   58:          (write-to-string (vector x x x) write/ss)))
   59: (test* "vector (circular)" "#0=#(#0#)"
   60:        (let1 x (vector 0)
   61:          (vector-set! x 0 x)
   62:          (write-to-string x write/ss)))
   63: 
   64: (test* "string" "(#0=\"ab\" . #0#)"
   65:        (let1 x "ab"
   66:          (write-to-string (cons x x) write/ss)))
   67: (test* "string" "(\"\" . \"\")"
   68:        (let1 x ""
   69:          (write-to-string (cons x x) write/ss)))
   70: 
   71: (test* "more than 10 substructures"
   72:        "(#0=(a) #1=(b) #2=(c) #3=(d) #4=(e) #5=(f) #6=(g) #7=(h) #8=(i) #9=(j) #10=(k) #10# #9# #8# #7# #6# #5# #4# #3# #2# #1# #0#)"
   73:        (let ((a '(a)) (b '(b)) (c '(c)) (d '(d)) (e '(e))
   74:              (f '(f)) (g '(g)) (h '(h)) (i '(i)) (j '(j)) (k '(k)))
   75:          (write-to-string
   76:           (list a b c d e f g h i j k
   77:                 k j i h g f e d c b a)
   78:           write/ss)))
   79: 
   80: (define-class <foo> ()
   81:   ((a :init-keyword :a)
   82:    (b :init-keyword :b)))
   83: (define-method write-object ((self <foo>) port)
   84:   (format port "#,(foo ~s ~s)" (ref self 'a) (ref self 'b)))
   85: 
   86: (test* "user defined" "#,(foo #0=(a b) #0#)"
   87:        (let* ((x '(a b))
   88:               (foo (make <foo> :a x :b x)))
   89:          (write-to-string foo write/ss)))
   90: (test* "user defined" "#0=#,(foo #0# #0#)"
   91:        (let ((foo (make <foo> :a #f :b #f)))
   92:          (set! (ref foo 'a) foo)
   93:          (set! (ref foo 'b) foo)
   94:          (write-to-string foo write/ss)))
   95: (test* "user defined" "#0=#,(foo foo #,(foo bar #0#))"
   96:        (let* ((foo (make <foo> :a 'foo :b #f))
   97:               (bar (make <foo> :a 'bar :b foo)))
   98:          (set! (ref foo 'b) bar)
   99:          (write-to-string foo write/ss)))
  100: (test* "user defined" "(#0=#,(foo foo #1=#,(foo bar #0#)) #1#)"
  101:        (let* ((foo (make <foo> :a 'foo :b #f))
  102:               (bar (make <foo> :a 'bar :b foo)))
  103:          (set! (ref foo 'b) bar)
  104:          (write-to-string (list foo bar) write/ss)))
  105: (test* "user defined" "#0=(#1=#,(foo #2=#,(foo bar #1#) #0#) #2#)"
  106:        (let* ((foo (make <foo> :a 'foo :b #f))
  107:               (bar (make <foo> :a 'bar :b foo))
  108:               (baz (list foo bar)))
  109:          (set! (ref foo 'a) bar)
  110:          (set! (ref foo 'b) baz)
  111:          (write-to-string baz write/ss)))
  112: 
  113: ;; write/ss with user-defined write-object method.
  114: ;; test by UEYAMA Rui
  115: (define-class <bar> ()
  116:   ((a :init-keyword :a)
  117:    (b :init-keyword :b)))
  118: (define-method write-object ((self <bar>) port)
  119:   (display "#,(bar " port)
  120:   (write/ss (ref self 'a) port)
  121:   (display " " port)
  122:   (write/ss (ref self 'b) port)
  123:   (display ")" port))
  124: (test* "user defined" "#,(bar #0=(a b) #0#)"
  125:        (let* ((x '(a b))
  126:               (bar (make <bar> :a x :b x)))
  127:          (write-to-string bar write/ss)))
  128: 
  129: ;;---------------------------------------------------------------
  130: (test-section "format/ss")
  131: 
  132: (test* "format/ss" "The answer is #0=(\"a\" . #0#)"
  133:        (let ((a (list "a")))
  134:          (set-cdr! a a)
  135:          (format/ss "The answer is ~s" a)))
  136: 
  137: (test* "format/ss" "The answer is #0=(a . #0#)"
  138:        (let ((a (list "a")))
  139:          (set-cdr! a a)
  140:          (format/ss "The answer is ~a" a)))
  141: 
  142: (test* "format/ss" "The answer is #0=(a . #0#) #0=(a . #0#)"
  143:        (let ((a (list 'a)))
  144:          (set-cdr! a a)
  145:          (format/ss "The answer is ~s ~s" a a)))
  146: 
  147: ;;---------------------------------------------------------------
  148: (test-section "read/ss basic")
  149: 
  150: ;; NB: in gauche, read/ss is just an alias of read.
  151: (test* "scalar (harmless)" 0
  152:        (read-from-string "#0=0"))
  153: (test* "scalar (harmless)" 1
  154:        (read-from-string "#1=1"))
  155: (test* "scalar (harmless)" 2
  156:        (read-from-string "#0=#1=2"))
  157: (test* "scalar (harmless)" #f
  158:        (read-from-string "#1=#10=#100=#f"))
  159: (test* "scalar (harmless)" "aaa"
  160:        (read-from-string "#1=#0=\"aaa\""))
  161: 
  162: (test* "bad syntax" *test-error*
  163:        (read-from-string "#1"))
  164: (test* "bad syntax" *test-error*
  165:        (read-from-string "#3#"))
  166: (test* "bad syntax" *test-error*
  167:        (read-from-string "#99999999999999999999999999999999999=3"))
  168: (test* "bad syntax" *test-error*
  169:        (read-from-string "#99999999999999999999999999999999999#"))
  170: 
  171: (test* "pair 1" (circular-list 1 2)
  172:        (read-from-string "#0=(1 2 . #0#)")
  173:        isomorphic?)
  174: (test* "pair 2" (let1 r (list #f) (set! (car r) r) r)
  175:        (read-from-string "#0=(#0#)")
  176:        isomorphic?)
  177: (test* "pair 3" (let1 r '(a b) (list r r r))
  178:        (read-from-string "(#0=#1=(a b) #0# #1#)")
  179:        isomorphic?)
  180: 
  181: (test* "vector" (let* ((r (vector 'a 'b))
  182:                        (s (vector 'c 'd))
  183:                        (t (vector r s r s 'e)))
  184:                   (vector-set! r 1 s)
  185:                   (vector-set! s 1 r)
  186:                   (vector-set! t 4 t)
  187:                   t)
  188:        (read-from-string "#0=#(#1=#(a #2=#(c #1#)) #2# #1# #2# #0#)")
  189:        isomorphic?)
  190: 
  191: (test* "string" (let* ((r (string #\a #\a))
  192:                        (s (string #\a #\a)))
  193:                   (list r s r s))
  194:        (read-from-string "(#0=\"aa\" #1=\"aa\" #0# #1#)")
  195:        isomorphic?)
  196: 
  197: ;; NB: this is an experimental feature.  Do not count on this API!
  198: (define-reader-ctor 'foo
  199:   (lambda x `(quote ,x))
  200:   (lambda (obj)
  201:     (pair-for-each (lambda (p)
  202:                      (when (read-reference? (car p))
  203:                        (set-car! p (read-reference-value (car p)))))
  204:                    (cadr obj))))
  205: 
  206: (test* "user-defined" '#0='(a #0#)
  207:        (read-from-string "#0=#,(foo a #0#)")
  208:        isomorphic?)
  209: 
  210: (test-end)