From patchwork Fri Sep 8 08:59:59 2017 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 811392 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-461703-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="qfMUbSfN"; dkim-atps=neutral Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 3xpWWF1yCjz9sBZ for ; Fri, 8 Sep 2017 19:00:41 +1000 (AEST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; q=dns; s=default; b=SR6ibYaLC9IjkT54VriC+HhYxxP33ar9g9iiIVjLfW60sV0Zwq 9A1Zieyc5k9WXTYC+BV0oc25vvNBJYkApjDtBh9lvmXxr4xFJwDGuKdkcOSyjOtj NVpLzWXTaAxYp8Q98vOXSxe1kG3uYg8HHZKQDmEUTAma54cAWtmEPD9NI= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; s= default; bh=AU2msAm5uADW7mHZRRbkiLPo0Ow=; b=qfMUbSfNWOMAo0ZR/owh NMajmatR8kND8YT2y3KTWb8+3sfE1yiWnhoHzX65rZg0NQmwr3xndVgwOoeL0BNP FRcyM8RbxaF6go9dk9ZYkWdpg49HvVRlAOZY8BdvEihWVb/93IvUQ393hOoeXs3E tmnvFE5ksCD5i736IuD5LU8= Received: (qmail 101901 invoked by alias); 8 Sep 2017 09:00:29 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 97527 invoked by uid 89); 8 Sep 2017 09:00:18 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-11.9 required=5.0 tests=BAYES_00, GIT_PATCH_2, GIT_PATCH_3, RCVD_IN_DNSWL_NONE, SPF_PASS, T_FILL_THIS_FORM_SHORT autolearn=ham version=3.3.2 spammy=communication X-HELO: rock.gnat.com Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Fri, 08 Sep 2017 09:00:01 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id A8D8656260; Fri, 8 Sep 2017 04:59:59 -0400 (EDT) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id cYkTFzNCrBZB; Fri, 8 Sep 2017 04:59:59 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [IPv6:2620:20:4000:0:46a8:42ff:fe0e:e294]) by rock.gnat.com (Postfix) with ESMTP id 96AC55619D; Fri, 8 Sep 2017 04:59:59 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4192) id 95B1E505; Fri, 8 Sep 2017 04:59:59 -0400 (EDT) Date: Fri, 8 Sep 2017 04:59:59 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Infinite loop on an interface conversion involving private extensions. Message-ID: <20170908085959.GA68804@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) 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 * sem_type.adb (Expand_Interface_Conversion): Prevent an infinite loop on an interface declared as a private extension of another synchronized interface. Index: sem_type.adb =================================================================== --- sem_type.adb (revision 251863) +++ sem_type.adb (working copy) @@ -2947,11 +2947,14 @@ -- Continue climbing else - -- Use the full-view of private types (if allowed) + -- Use the full-view of private types (if allowed). + -- Guard against infinite loops when full view has same + -- type as parent, as can happen with interface extensions, if Use_Full_View and then Is_Private_Type (Par) and then Present (Full_View (Par)) + and then Par /= Etype (Full_View (Par)) then Par := Etype (Full_View (Par)); else