1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
|
;; Filename : test-srfi38.scm
;; About : unit test for SRFI-38
;;
;; Copyright (C) 2005-2006 Kazuki Ohta <mover AT hct.zaq.ne.jp>
;; Copyright (c) 2007-2008 SigScheme Project <uim-en AT googlegroups.com>
;;
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;;
;; 1. Redistributions of source code must retain the above copyright
;; notice, this list of conditions and the following disclaimer.
;; 2. Redistributions in binary form must reproduce the above copyright
;; notice, this list of conditions and the following disclaimer in the
;; documentation and/or other materials provided with the distribution.
;; 3. Neither the name of authors nor the names of its contributors
;; may be used to endorse or promote products derived from this software
;; without specific prior written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(require-extension (unittest))
(require-extension (srfi 6 38))
(if (not (provided? "srfi-38"))
(test-skip "SRFI-38 is not enabled"))
(define tn test-name)
(if (not (symbol-bound? 'cadddr))
(define cadddr
(lambda (lst)
(caddr (cdr lst)))))
(tn "write/ss short-name alias")
(if sigscheme?
(begin
(assert-true (tn) (symbol-bound? 'write/ss))
(assert-true (tn) (string-eval
"(eq? write/ss write-with-shared-structure)"))))
(tn "write/ss invalid form")
(assert-error (tn) (lambda ()
(write-with-shared-structure)))
(assert-error (tn) (lambda ()
(write-with-shared-structure #f . (current-output-port))))
(assert-error (tn) (lambda ()
(write-with-shared-structure #f (current-output-port) . #t)))
(if sigscheme?
(assert-error (tn) (lambda ()
(write-with-shared-structure
#f (current-output-port) #t . #t))))
(tn "write/ss with implicit port")
(print-expected "\"abc\"")
(write-with-shared-structure "abc")
(newline)
(tn "write/ss with explicit port arg")
(let* ((outs (open-output-string))
(s "abc")
(convolution `(,s 1 #(,s b) ,(list 2) () ,s)))
; go crazy with mutators
(set-car! (cdr convolution) convolution)
(vector-set! (caddr convolution) 1 (cddr convolution))
(set-cdr! (cadddr convolution) (cdr convolution))
(write-with-shared-structure convolution outs)
(assert-equal? (tn)
"#1=(#2=\"abc\" . #3=(#1# . #4=(#(#2# #4#) (2 . #3#) () #2#)))"
(get-output-string outs)))
(let* ((outs (open-output-string))
(a-pair (cons 'kar 'kdr))
(convolution (eval (list 'lambda () a-pair) (scheme-report-environment 5))))
(set-cdr! a-pair convolution)
(write-with-shared-structure convolution outs)
(assert-equal? (tn)
"#1=#<closure (() (kar . #1#))>"
(get-output-string outs)))
(tn "write/ss with explicit port arg and optarg")
(let ((p (open-output-string)))
(write-with-shared-structure "abc" p #t)
(assert-equal? (tn) "\"abc\"" (get-output-string p)))
(if sigscheme?
(let ((p (open-output-string)))
(write-with-shared-structure "abc" p #t #t) ;; accepts 2+ optarg
(assert-equal? (tn) "\"abc\"" (get-output-string p))))
(total-report)
|
