1-- { dg-do run } 2 3with Interfaces; use Interfaces; 4 5procedure Access7 is 6 type t_p_string is access constant String; 7 subtype t_hash is Unsigned_32; 8 9 -- Return a hash value for a given string 10 function hash(s: String) return t_hash is 11 h: t_hash := 0; 12 g: t_hash; 13 begin 14 for i in s'Range loop 15 h := Shift_Left(h, 4) + t_hash'(Character'Pos(s(i))); 16 g := h and 16#F000_0000#; 17 if (h and g) /= 0 then 18 h := h xor ((Shift_Right(g, 24) and 16#FF#) or g); 19 end if; 20 end loop; 21 return h; 22 end hash; 23 24 type hash_entry is record 25 v: t_p_string; 26 hash: t_hash; 27 next: access hash_entry; 28 end record; 29 30 type hashtable is array(t_hash range <>) of access hash_entry; 31 32 protected pool is 33 procedure allocate (sp: out t_p_string; s: String; h: t_hash); 34 private 35 tab: hashtable(0..199999-1) := (others => null); 36 end pool; 37 38 protected body pool is 39 procedure allocate(sp: out t_p_string; s: String; h: t_hash) is 40 p: access hash_entry; 41 slot: t_hash; 42 begin 43 slot := h mod tab'Length; 44 p := tab(slot); 45 while p /= null loop 46 -- quickly check hash, then length, only then slow comparison 47 if p.hash = h and then p.v.all'Length = s'Length 48 and then p.v.all = s 49 then 50 sp := p.v; -- shared string 51 return; 52 end if; 53 p := p.next; 54 end loop; 55 -- add to table 56 p := new hash_entry'(v => new String'(s), 57 hash => h, 58 next => tab(slot)); 59 tab(slot) := p; -- { dg-warning "accessibility check fails|Program_Error will be raised at run time" } 60 sp := p.v; -- shared string 61 end allocate; 62 end pool; 63 64 -- Return the pooled string equal to a given String 65 function new_p_string(s: String) return t_p_string is 66 sp: t_p_string; 67 begin 68 pool.allocate(sp, s, hash(s)); 69 return sp; 70 end new_p_string; 71 72 foo_string : t_p_string; 73begin 74 foo_string := new_p_string("foo"); 75 raise Constraint_Error; 76exception 77 when Program_Error => 78 null; 79end Access7; 80