blob: e48131218785c9260f5d3f3c616d40ac7562ef89 [file] [log] [blame]
-- { 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;
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);
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;
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
sp := p.v; -- shared string
end if;
p :=;
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;
pool.allocate(sp, s, hash(s));
return sp;
end new_p_string;
foo_string : t_p_string;
foo_string := new_p_string("foo");
raise Constraint_Error;
when Program_Error =>
end Access7;