[Ada] Infinite loop on an interface conversion involving private extensions.

[Arnaud Charlet <charlet at adacore dot com>]

This patch fixes a loop in the compiler, on an interface conversion from an
interface declared as a synchronized private extension to one of its ancestors.

databases-instantiations,adb below must compile quietly:

---
package body Databases.Generics is
   New_Data_ID : Data_ID_Type := 1;

   protected body Database_Type is

      procedure Register
        (Data_Name : in Data_Name_Type;
         Data_ID   : out Data_ID_Type)
      is
         Tmp_Data_ID : constant Data_ID_Type := New_Data_ID;
      begin
         Data_Names (Data_ID) := Data_Name;
         Data_Objects_Map (Data_ID) := Data_Object'
           (Data      => Init_Data,
            Timestamp => Time_First);

         New_Data_ID := New_Data_ID + 1;

         Data_ID := Tmp_Data_ID;
      end Register;

      procedure Set
        (Data_ID  : in Data_ID_Type;
         Raw_Data : in UInt8_Array)
      is
         Data : Data_Type with Address => Raw_Data'Address;
      begin
         Set
           (Data_ID => Data_ID,
            Data    => Data);
      end Set;

      function Get
        (Data_ID : in Data_ID_Type) return UInt8_Array
      is
         Data_Size : constant Natural := Data_Type'Size / 8;
         Data      : constant Data_Type := Get (Data_ID);
         Raw_Data  : UInt8_Array (1 .. Data_Size) with Address => Data'Address;
      begin
         return Raw_Data;
      end Get;

      procedure Set
        (Data_ID : in Data_ID_Type;
         Data    : in Data_Type)
      is
      begin
         Data_Objects_Map (Data_ID).Timestamp := Clock;
         Data_Objects_Map (Data_ID).Data := Data;
      end Set;

      function Get
        (Data_ID : in Data_ID_Type) return Data_Type is
      begin
         return Data_Objects_Map (Data_ID).Data;
      end Get;

      function Get_Timestamp
        (Data_ID  : in Data_ID_Type) return Ada.Real_Time.Time is
      begin
         return Data_Objects_Map (Data_ID).Timestamp;
      end Get_Timestamp;

   end Database_Type;

   function Get_Database_Instance return Database_Access is
   begin
      return Database_Instance'Access;
   end Get_Database_Instance;

end Databases.Generics;
with Ada.Real_Time; use Ada.Real_Time;
with Databases;     use Databases;
generic
   type Data_Type is private;
   --  The data type that should be stored in the database

   Init_Data   : Data_Type;
   --  The value that should be set just after the data registration

   Max_Nb_Data : Positive;
   --  The maximun number of data that can be stored in the database

package Databases.Generics is

   type Typed_Database_Interface is synchronized interface;

   function Get
     (Database : Typed_Database_Interface;
      Data_ID  : Data_ID_Type) return Data_Type is abstract;
   --  Get the currently set value for given Data_ID

   function Get_Timestamp
     (Database : Typed_Database_Interface;
      Data_ID  : Data_ID_Type) return Time is abstract;

   procedure Set
     (Database : in out Typed_Database_Interface;
      Data_ID  : Data_ID_Type;
      Data     : Data_Type) is abstract;
   --  Set a value for the given Data_ID

   type Database_Type is synchronized new Root_Database_Type
     and Typed_Database_Interface with private;
   type Database_Access is access all Database_Type'Class;
   --  Database types for the given Data_Type.

   function Get_Database_Instance return Database_Access;
   --  Return the unique database instance for this package.
private
   type Data_Object is record
      Data      : Data_Type;
      Timestamp : Ada.Real_Time.Time;
   end record;

   type Data_Object_Array is
     array (Data_ID_Type'First .. Data_ID_Type (Max_Nb_Data)) of Data_Object;

   protected type Database_Type is new Root_Database_Type
        and Typed_Database_Interface with

      overriding procedure Register
        (Data_Name : in Data_Name_Type;
         Data_ID   : out Data_ID_Type);

      overriding function Get
        (Data_ID : in Data_ID_Type) return UInt8_Array;

      overriding procedure Set
        (Data_ID  : in Data_ID_Type;
         Raw_Data : UInt8_Array);

      overriding function Get
        (Data_ID : in Data_ID_Type) return Data_Type;
      --  Get the currently set value for given Data_ID

      overriding function Get_Timestamp
        (Data_ID : in Data_ID_Type) return Time;

      overriding procedure Set
        (Data_ID : in Data_ID_Type;
         Data    : in Data_Type);
         --  Set a value for the given Data_ID
   private
      ID               : Database_ID_Type := Get_New_Database_ID;
      Data_Objects_Map : Data_Object_Array;
      Data_Names       : Data_Name_Array;
   end Database_Type;

   Database_Instance : aliased Database_Type;

end Databases.Generics;
package body Databases.Instantiations is

   procedure Set_Raw_Data
     (Database_ID : Database_ID_Type;
      Data_ID     : Data_ID_Type;
      Raw_Data    : UInt8_Array) is
   begin
      Databases (Database_ID).Set
        (Data_ID  => Data_ID,
         Raw_Data => Raw_Data);
   end Set_Raw_Data;

   function Get_Raw_Data
     (Database_ID : Database_ID_Type;
      Data_ID     : Data_ID_Type)
      return UInt8_Array
   is
   begin
      return Databases (Database_ID).Get (Data_ID);
   end Get_Raw_Data;

end Databases.Instantiations;
with Databases.Generics;
package Databases.Instantiations is

   procedure Set_Raw_Data
     (Database_ID : Database_ID_Type;
      Data_ID     : Data_ID_Type;
      Raw_Data    : UInt8_Array);
   --  Should be used by the Communication module.

   function Get_Raw_Data
     (Database_ID : Database_ID_Type;
      Data_ID     : Data_ID_Type) return UInt8_Array;
   --  Should be used by the Communication module

   package Integer_Databases is new Databases.Generics
     (Integer,
      Init_Data   => 0,
      Max_Nb_Data => 10);

   package Float_Databases is new Databases.Generics
     (Float,
      Init_Data   => 0.0,
      Max_Nb_Data => 10);
private
   First_ID : constant Database_ID_Type := Database_ID_Type'First;
   Last_ID  : constant Database_ID_Type := Get_Last_Database_ID;

   Databases : constant Root_Database_Array (First_ID .. First_ID + 1) :=
                 (First_ID     => Root_Database_Access
                    (Integer_Databases.Get_Database_Instance),
                  First_ID + 1 => Root_Database_Access
                    (Float_Databases.Get_Database_Instance));

end Databases.Instantiations;
package body Databases is

   New_DB_ID : Database_ID_Type := 1;

   function Get_New_Database_ID return Database_ID_Type
   is
      DB_ID : constant Database_ID_Type := New_DB_ID;
   begin
      New_DB_ID := New_DB_ID + 1;

      return DB_ID;
   end Get_New_Database_ID;

   function Get_Last_Database_ID return Database_ID_Type is
   begin
      return New_DB_ID;
   end Get_Last_Database_ID;

end Databases;
with Interfaces;
package Databases is

   type UInt8 is new Interfaces.Unsigned_8;
   type UInt8_Array is array (Natural range <>) of UInt8;

   subtype Data_Name_Type is String (1 .. 16);
   --  16-Characters names used to register the data stored in databases

   type Database_ID_Type is private;
   --  Non-string based IDs for databases.
   --  Created when creating a new database instance.

   type Data_ID_Type is new Positive;
   --  Non-string based IDs for data stored in databases.
   --  Created when registering data in databases.

   type Root_Database_Type is synchronized interface;
   type Root_Database_Access is access all Root_Database_Type'Class;
   --  The root abstract type for all databases

   procedure Register
     (Database  : in out Root_Database_Type;
      Data_Name : Data_Name_Type;
      Data_ID   : out Data_ID_Type) is abstract;
   --  Register data to store in the given Database, associating it with
   --  Data_Name.
   --  The returned ID should be used for later transactions.

   function Get
     (Database : Root_Database_Type;
      Data_ID  : Data_ID_Type) return UInt8_Array is abstract;
   --  Get the currently set value for given Data_ID in a raw data format

   procedure Set
     (Database : in out Root_Database_Type;
      Data_ID  : Data_ID_Type;
      Raw_Data : UInt8_Array) is abstract;
   --  Set a raw data value for the given Data_ID

private
   type Database_ID_Type is new Positive;

   type Root_Database_Array is
     array (Database_ID_Type range <>) of Root_Database_Access;

   type Data_Name_Array is array (Data_ID_Type'First .. 16) of Data_Name_Type;

   function Get_New_Database_ID return Database_ID_Type;
   --  Used to get a new database ID each time a databse is instantiated

   function Get_Last_Database_ID return Database_ID_Type;
   --  Return the lastly created database ID
end Databases;

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

2017-09-08  Ed Schonberg  <schonberg@adacore.com>

	* sem_type.adb (Expand_Interface_Conversion): Prevent an infinite
	loop on an interface declared as a private extension of another
	synchronized interface.

Attachment: difs
Description: Text document