[Ada] Warn on accessibility error in generic instance

[Arnaud Charlet <charlet at adacore dot com>]

This patch adds a warning when we detect an inevitable accessibility
error (raising program error) in a generic instance.

The following test program compiled with -gnat05 -gnatp yields
the compile time warnings:

test000.adb:19:04: warning: in instantiation at ilists.adb:31
test000.adb:19:04: warning: accessibility check failure
test000.adb:19:04: warning: "Program_Error" will be raised at run time

and the run time output:

raised PROGRAM_ERROR : ilists.adb:31 accessibility check failed

package body Ilists is

   package body Lists is

      function Ptr (Which : Boolean; X : access T) return access T;
      procedure Set_Ptr (Which : Boolean; X : access T; NX : access T);
      pragma Inline (Ptr);
      pragma Inline (Set_Ptr);

      procedure Remove
        (L              : in out List;
         Item, Previous : access T);

      procedure Append (L : in out List; X : access T) is
      begin
         if L.Last /= null then
            if Doubly_Linked then
               Set_Ptr (Prev_Node, X, L.Last);
            end if;
            Set_Ptr (Next_Node, L.Last, X);
         end if;
         L.Last := X;
         if L.First = null then
            L.First := X;
         end if;
         L.Length := L.Length + 1;
      end Append;

      function First (L : List) return Iterator is
      begin
         return Iterator (L.First);
      end First;

      function Is_Empty (L : List) return Boolean is
      begin
         return L.Length = 0;
      end Is_Empty;

      function Last (It : Iterator) return Boolean is
      begin
         return It = null;
      end Last;

      function Length (L : List) return Natural is
      begin
         return L.Length;
      end Length;

      procedure Next (It : in out Iterator) is
      begin
         It := Iterator (Ptr (Next_Node, It));
      end Next;

      function Ptr (Which : Boolean; X : access T) return access T is
      begin
         return T (List_Data (X).Pointers (Which).all)'Access;
      end Ptr;

      procedure Remove (L : in out List; X : access T) is
      begin
         Remove (L, X, Ptr (Prev_Node, X));
      end Remove;

      procedure Remove (L : in out List; It : Iterator) is
      begin
         Remove (L, It, Ptr (Prev_Node, It));
      end Remove;

      procedure Remove
        (L              : in out List;
         Item, Previous : access T)
      is
      begin
         if Previous = null then
            L.First := Ptr (Next_Node, Item);
         else
            Set_Ptr (Next_Node, Previous, Ptr (Next_Node, Item));
         end if;

         if L.Last = Item then
            L.Last := Previous;
         end if;

         if Doubly_Linked then
            if Ptr (Next_Node, Item) /= null then
               Set_Ptr (Prev_Node, Ptr (Next_Node, Item), Previous);
            end if;
         end if;
         L.Length := L.Length - 1;
      end Remove;

      procedure Set_Ptr (Which : Boolean; X : access T; NX : access T) is
      begin
         List_Data (X).Pointers (Which) := NX;
      end Set_Ptr;

      function Value (It : Iterator) return access T is
      begin
         return It.all'Access;
      end Value;

   end Lists;

end Ilists;
package Ilists is

   pragma Preelaborate;

   type Chainable is limited interface;
   type List_Private_Data (Doubly_Linked : Boolean) is private;

   generic
      type T (<>) is new Chainable with private;
      with function List_Data
                      (X : access T) return access List_Private_Data is <>;

      Doubly_Linked : Boolean;

   package Lists is
      type List is limited private;
      type Iterator is private;

      procedure Append (L : in out List; X : access T);
      procedure Remove (L : in out List; X : access T);
      procedure Remove (L : in out List; It : Iterator);

      function First (L : List) return Iterator;
      procedure Next (It : in out Iterator);
      function Last (It : Iterator) return Boolean;
      function Value (It : Iterator) return access T;

      function Length (L : List) return Natural;
      function Is_Empty (L : List) return Boolean;

   private
      type List is record
         First, Last : access T;
         Length      : Natural := 0;
      end record;
      type Iterator is access all T;
   end Lists;

private

   type List_Pointers_Array is array (Boolean range <>)
     of access Chainable'Class;
   pragma Suppress (Index_Check, List_Pointers_Array);
   --  No index checks are required for accesses to List_Pointers_Array,
   --  because all cases of access to List_Pointers (Prev) are protected by
   --  an 'if Doubly_Linked' condition.

   Next_Node : constant Boolean := False;
   Prev_Node : constant Boolean := True;

   type List_Private_Data (Doubly_Linked : Boolean) is record
      Pointers : List_Pointers_Array (False .. Doubly_Linked);
   end record;

end Ilists;
with Ada.Text_IO; use Ada.Text_IO;
with Ilists;

procedure Test000 is

   use Ilists;

   type Chainable_Integer is new Chainable with record
      List_Data : aliased List_Private_Data (Doubly_Linked => True);
      Int_Value : Integer;
   end record;

   function List_Data (X : access Chainable_Integer)
      return access List_Private_Data is
   begin
      return X.List_Data'Access;
   end List_Data;

   package Ls is new Ilists.Lists
     (Chainable_Integer, Doubly_Linked => True);
   use Ls;
   type A is array (Integer range <>) of Integer;

   function To_Array (L : List) return A;
   function To_Array (L : List) return A is
      Result : A (1 .. Length (L));
      Index : Integer := Result'First;
      It : Iterator := First (L);
   begin
      while not Last (It) loop
         Result (Index) := Value (It).Int_Value;
         Index := Index + 1;
         Next (It);
      end loop;

      if Index /= Result'Last + 1 then
         raise Program_Error;
      end if;
      return Result;
   end To_Array;

   L1 : List;

   I123, I456, I789 : aliased Chainable_Integer;

   procedure Output (S : String; B : Boolean) is
   begin
      Put_Line (S & "-->" & B'Img);
   end Output;

begin
   I123.Int_Value := 123;
   I456.Int_Value := 456;
   I789.Int_Value := 789;

   Output ("empty", To_Array (L1)'Length = 0);
   Append (L1, I123'Access);
   Output ("single L1", To_Array (L1) = (1 => 123));

   Append (L1, I456'Access);
   Output ("double L1", To_Array (L1) = (1 => 123, 2 => 456));
end Test000;

Tested on x86_64-pc-linux-gnu, committed on trunk

2009-07-10  Robert Dewar  <dewar@adacore.com>

	* exp_ch4.adb (Raise_Accessibility_Error): New procedure

Attachment: difs
Description: Text document