blob: 6d56ed929ad6ac01305ffe228641a74459e09d44 (
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
|
set cc [c create]
$cc code {
Tcl_Obj* sentinel;
bool freedSentinel = false;
void sentinel_freeIntRepProc(Tcl_Obj *objPtr) {
printf("freed sentinel! %p\n", objPtr);
freedSentinel = true;
}
void sentinel_dupIntRepProc(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) {}
void sentinel_updateStringProc(Tcl_Obj *objPtr) {
objPtr->bytes = ckalloc(10);
objPtr->length = snprintf(objPtr->bytes, 10, "SENTINEL");
}
int sentinel_setFromAnyProc(Tcl_Interp *interp, Tcl_Obj *objPtr) {
return TCL_ERROR;
}
Tcl_ObjType sentinel_ObjType = (Tcl_ObjType) {
.name = "sentinel",
.freeIntRepProc = sentinel_freeIntRepProc,
.dupIntRepProc = sentinel_dupIntRepProc,
.updateStringProc = sentinel_updateStringProc,
.setFromAnyProc = sentinel_setFromAnyProc
};
}
$cc proc makeSentinel {} Tcl_Obj* {
sentinel = Tcl_NewObj();
sentinel->bytes = NULL;
sentinel->typePtr = &sentinel_ObjType;
freedSentinel = false;
printf("allocated sentinel %p\n", sentinel);
return sentinel;
}
$cc proc checkIfFreedSentinel {} bool { return freedSentinel; }
$cc proc sentinelRefCount {} int { return sentinel->refCount; }
$cc compile
set x [makeSentinel]
set x none
assert [checkIfFreedSentinel]
puts -------------------------------------
Assert there is a sentinel [makeSentinel]
Step
Retract there is a sentinel /any/
Step
assert [checkIfFreedSentinel]
puts -------------------------------------
Assert A has program code {
When the collected matches for [list /someone/ is a [makeSentinel]] are /matches/ {
Claim ok
}
}
Step
Retract A has program code /any/
Step
assert [checkIfFreedSentinel]
|
