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
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
|
(load "write.scm")
(load "s7test-block.so" (sublet (curlet) (cons 'init_func 'block_init)))
(set! (*s7* 'print-length) 8) ; :readable should ignore this
(set! (*s7* 'default-hash-table-length) 4)
;(set! (*s7* 'heap-size) (* 10 1024000))
(define (all-copy v1 v2)
(do ((i 0 (+ i 1)))
((= i 7))
(vector-set! v2 i (copy (vector-ref v1 i)))))
(define (tester)
(let ((base-vector (vector (make-list 3 #f)
(make-vector 3 #f)
(make-cycle #f)
(hash-table 'a 1 'b 2 'c 3)
(inlet 'a 1 'b 2 'c 3)
(make-iterator (make-list 3 #f))
(c-pointer 1 (make-list 3 #f)))))
(do ((baddies 0)
(size 3 (+ size 1)))
((= size 4))
(format *stderr* "~%-------- ~D --------~%" size)
(do ((tries (* 2000 (expt 3 size)))
(k 0 (+ k 1)))
((or (= k tries)
(> baddies 1)))
(let ((cp-lst (make-list 3 #f))
(it-lst (make-list 3 #f)))
(let ((bases (make-vector 7))
(sets ())
(b1 0)
(b2 0))
(all-copy base-vector bases)
(do ((i 0 (+ i 1))
(r1 (random 7) (random 7))
(r2 (random 7) (random 7))
(loc (random 3) (random 3)))
((= i size))
(set! b1 (bases r1))
(set! b2 (bases r2))
(case (type-of b1)
((pair?)
(if (> (random 10) 3)
(begin
(set! (b1 loc) b2)
(set! sets (cons (list r1 loc r2) sets)))
(begin
(set-cdr! (cddr b1) (case loc ((0) b1) ((1) (cdr b1)) (else (cddr b1))))
(set! sets (cons (list r1 (+ loc 3) r2) sets)))))
((vector?)
(set! (b1 loc) b2)
(set! sets (cons (list r1 loc r2) sets)))
((c-object?)
(set! (b1 0) b2)
(set! sets (cons (list r1 0 r2) sets)))
((hash-table? let?)
(let ((key (#(a b c) loc)))
(set! (b1 key) b2)
(set! sets (cons (list r1 key r2) sets))))
((c-pointer?)
(set! (cp-lst loc) b2)
(set! sets (cons (list r1 loc r2) sets)))
((iterator?)
(set! (it-lst loc) b2)
(set! sets (cons (list r1 loc r2) sets)))))
(let ((bi 0))
(for-each
(lambda (x)
(let ((str (object->string x :readable)))
(unless (equal? x (eval-string str))
(set! baddies (+ baddies 1))
(format *stderr* "x: ~S~%" x)
(format *stderr* "ex: ~S~%" (eval-string str))
(format *stderr* "sets: ~S~%" (reverse sets))
(format *stderr* "str: ~S~%" str)
(pretty-print (with-input-from-string str read) *stderr* 0)
(format *stderr* "~%~%")
(format *stderr* "
(let ((p (make-list 3 #f))
(v (make-vector 3 #f))
(cy (make-cycle #f))
(h (hash-table 'a 1 'b 2 'c 3))
(e (inlet 'a 1 'b 2 'c 3))
(it (make-iterator (make-list 3 #f)))
(cp (c-pointer 1 (make-list 3 #f))))
")
(for-each
(lambda (set)
(cond ((and (zero? (car set))
(> (cadr set) 2))
(format *stderr* " (set-cdr! (list-tail p 2) ~A)~%"
(#("p" "(cdr p)" "(cddr p)") (- (cadr set) 3))))
((< (car set) 5)
(format *stderr* " (set! (~A ~A) ~A)~%"
(#(p v cy h e) (car set))
(case (car set)
((0 1) (cadr set))
((2) 0)
((3) (format #f "~W" (cadr set)))
((4) (symbol->keyword (cadr set))))
(#(p v cy h e it cp) (caddr set))))
((= (car set) 5)
(format *stderr* " (set! ((iterator-sequence it) ~A) ~A)~%"
(cadr set)
(#(p v cy h e it cp) (caddr set))))
(else (format *stderr* " (set! (((object->let cp) 'c-type) ~A) ~A)~%"
(cadr set)
(#(p v cy h e it cp) (caddr set))))))
sets)
(format *stderr* " ~A)~%" (#(p v cy h e it cp) bi)))
(set! bi (+ bi 1))))
bases))))))))
(tester)
(when (> (*s7* 'profile) 0)
(show-profile 200))
(exit)
|
