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