blob: fab95c952f37db38e6693d0cf9d771b3051692eb (
plain)
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
|
source [file dirname [info script]]/testing.tcl
needs constraint jim
needs cmd ref
needs cmd collect
test collect-1.1 {ensure globally scoped references are deleted} {
collect
set result {}
# Create a globally scoped reference as a function name
set a ::[ref testfunction -]
proc $a {} { return 3 }
lappend result [$a]
# It shouldn't be collected
lappend result [collect]
lappend result [$a]
unset a
# Now it should be collected
lappend result [collect]
set result
} {3 0 3 1}
test collect-1.2 {gc reference from command table with no other ref} {
# Create a lambda but don't call it
lambda {} {}
# And collect should remove it
collect
} 1
test collect-1.3 {gc reference from command table with one other ref, then no ref} {
# Create a lambda but don't call it
set x [lambda {} {}]
# And collect should not remove it (ref via $x)
set result {}
lappend result [collect]
unset x
# Now it should be collected
lappend result [collect]
set result
} {0 1}
test collect-1.4 {gc reference from command table with one other ref, then no ref} {
# Create a lambda
set x [lambda {} {}]
# And call it
$x
# And collect should not remove it (ref via $x)
set result {}
lappend result [collect]
unset x
# Now it should be collected
lappend result [collect]
set result
} {0 1}
test collect-1.5 {gc with two single refs to the same object} {
# Create a lambda
set x [lambda {} {}]
# And a second reference to it
set y ${x}1
set result {}
unset x
# now there is a singleton ref in the command table and y also refers to it
lappend result [collect]
unset y
lappend result [collect]
# And now only in the command table
set result
} {0 1}
test collect-1.6 {unexpected collect} -body {
package require oo
class t { val 0 }
t method setval {v} { set val $v }
proc final {ref value} { list "Destroy $ref" }
set l1 [list 99 96 98 97]
set l2 [lmap i $l1 {
set tt [t new]
finalize $tt final
list "Create $tt"
$tt setval $i
list $tt
}]
set getter [lambda {t} { list [$t get val] }]
set entries [lsort -command \
[lambda {a b} {upvar getter g; expr {[$g $a] - [$g $b]}}] $l2]
foreach e $entries { list "$e [$e get val]" }
# Should only collect the lsort lambda
collect
} -result {1} -cleanup {
unset l1
unset l2
unset getter
unset entries
unset e
collect
}
test getref-1.1 {getref basic functionality} {
set r [ref string tag]
getref $r
} string
test getref-1.2 {getref fully qualified} {
getref ::$r
} string
test setref-1.1 {setref basic functionality} {
setref $r string2
getref $r
} string2
test setref-1.2 {setref fully qualified} {
setref ::$r string3
getref ::$r
} string3
testreport
|
