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
|
-- { dg-do run }
with Interfaces; use Interfaces;
procedure Access7 is
type t_p_string is access constant String;
subtype t_hash is Unsigned_32;
-- Return a hash value for a given string
function hash(s: String) return t_hash is
h: t_hash := 0;
g: t_hash;
begin
for i in s'Range loop
h := Shift_Left(h, 4) + t_hash'(Character'Pos(s(i)));
g := h and 16#F000_0000#;
if (h and g) /= 0 then
h := h xor ((Shift_Right(g, 24) and 16#FF#) or g);
end if;
end loop;
return h;
end hash;
type hash_entry is record
v: t_p_string;
hash: t_hash;
next: access hash_entry;
end record;
type hashtable is array(t_hash range <>) of access hash_entry;
protected pool is
procedure allocate (sp: out t_p_string; s: String; h: t_hash);
private
tab: hashtable(0..199999-1) := (others => null);
end pool;
protected body pool is
procedure allocate(sp: out t_p_string; s: String; h: t_hash) is
p: access hash_entry;
slot: t_hash;
begin
slot := h mod tab'Length;
p := tab(slot);
while p /= null loop
-- quickly check hash, then length, only then slow comparison
if p.hash = h and then p.v.all'Length = s'Length
and then p.v.all = s
then
sp := p.v; -- shared string
return;
end if;
p := p.next;
end loop;
-- add to table
p := new hash_entry'(v => new String'(s),
hash => h,
next => tab(slot));
tab(slot) := p; -- { dg-warning "accessibility check fails|Program_Error will be raised at run time" }
sp := p.v; -- shared string
end allocate;
end pool;
-- Return the pooled string equal to a given String
function new_p_string(s: String) return t_p_string is
sp: t_p_string;
begin
pool.allocate(sp, s, hash(s));
return sp;
end new_p_string;
foo_string : t_p_string;
begin
foo_string := new_p_string("foo");
raise Constraint_Error;
exception
when Program_Error =>
null;
end Access7;
|
