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
|
//
//
// The Nimrod Compiler
// (c) Copyright 2008 Andreas Rumpf
//
// See the file "copying.txt", included in this
// distribution, for details about the copyright.
//
unit debugids;
interface
{$include 'config.inc'}
uses
nsystem, nos, strutils, ast;
const
idfile = 'debugids.txt';
// This module implements debugging facilities for the ID mechanism.
procedure registerID(s: PSym);
procedure writeIDTable();
procedure loadIDTable();
implementation
type
TIdSymTuple = record{@tuple} // keep id from sym to better detect bugs
id: int;
s: PSym;
end;
TIdSymTupleSeq = array of TIdSymTuple;
TIdSymTable = record
counter: int;
data: TIdSymTupleSeq;
end;
function TableRawGet(const t: TTable; key: PObject): int;
var
h: THash;
begin
h := hashNode(key) and high(t.data); // start with real hash value
while t.data[h].key <> nil do begin
if (t.data[h].key = key) then begin
result := h; exit
end;
h := nextTry(h, high(t.data))
end;
result := -1
end;
function TableSearch(const t: TTable; key, closure: PObject;
comparator: TCmpProc): PObject;
var
h: THash;
begin
h := hashNode(key) and high(t.data); // start with real hash value
while t.data[h].key <> nil do begin
if (t.data[h].key = key) then
if comparator(t.data[h].val, closure) then begin // BUGFIX 1
result := t.data[h].val; exit
end;
h := nextTry(h, high(t.data))
end;
result := nil
end;
function TableGet(const t: TTable; key: PObject): PObject;
var
index: int;
begin
index := TableRawGet(t, key);
if index >= 0 then result := t.data[index].val
else result := nil
end;
procedure TableRawInsert(var data: TPairSeq; key, val: PObject);
var
h: THash;
begin
h := HashNode(key) and high(data);
while data[h].key <> nil do begin
assert(data[h].key <> key);
h := nextTry(h, high(data))
end;
assert(data[h].key = nil);
data[h].key := key;
data[h].val := val;
end;
procedure TableEnlarge(var t: TTable);
var
n: TPairSeq;
i: int;
begin
{@ignore}
n := emptySeq;
setLength(n, length(t.data) * growthFactor);
fillChar(n[0], length(n)*sizeof(n[0]), 0);
{@emit
newSeq(n, length(t.data) * growthFactor); }
for i := 0 to high(t.data) do
if t.data[i].key <> nil then
TableRawInsert(n, t.data[i].key, t.data[i].val);
{@ignore}
t.data := n;
{@emit
swap(t.data, n);
}
end;
procedure TablePut(var t: TTable; key, val: PObject);
var
index: int;
begin
index := TableRawGet(t, key);
if index >= 0 then
t.data[index].val := val
else begin
if mustRehash(length(t.data), t.counter) then TableEnlarge(t);
TableRawInsert(t.data, key, val);
inc(t.counter)
end;
end;
end.
|