gcc/testsuite/gnat.dg/access7.adb

   1 --  { dg-do run }
   2
   3 with Interfaces; use Interfaces;
   4
   5 procedure 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;
  73 begin
  74    foo_string := new_p_string("foo");
  75    raise Constraint_Error;
  76 exception
  77    when Program_Error =>
  78       null;
  79 end Access7;