{"id":811392,"url":"http://patchwork.ozlabs.org/api/patches/811392/?format=json","web_url":"http://patchwork.ozlabs.org/project/gcc/patch/20170908085959.GA68804@adacore.com/","project":{"id":17,"url":"http://patchwork.ozlabs.org/api/projects/17/?format=json","name":"GNU Compiler Collection","link_name":"gcc","list_id":"gcc-patches.gcc.gnu.org","list_email":"gcc-patches@gcc.gnu.org","web_url":null,"scm_url":null,"webscm_url":null,"list_archive_url":"","list_archive_url_format":"","commit_url_format":""},"msgid":"<20170908085959.GA68804@adacore.com>","list_archive_url":null,"date":"2017-09-08T08:59:59","name":"[Ada] Infinite loop on an interface conversion involving private extensions.","commit_ref":null,"pull_url":null,"state":"new","archived":false,"hash":"8bbb574f78052ed91dcb357792bc1a3e9be04198","submitter":{"id":4418,"url":"http://patchwork.ozlabs.org/api/people/4418/?format=json","name":"Arnaud Charlet","email":"charlet@adacore.com"},"delegate":null,"mbox":"http://patchwork.ozlabs.org/project/gcc/patch/20170908085959.GA68804@adacore.com/mbox/","series":[{"id":2141,"url":"http://patchwork.ozlabs.org/api/series/2141/?format=json","web_url":"http://patchwork.ozlabs.org/project/gcc/list/?series=2141","date":"2017-09-08T08:59:59","name":"[Ada] Infinite loop on an interface conversion involving private extensions.","version":1,"mbox":"http://patchwork.ozlabs.org/series/2141/mbox/"}],"comments":"http://patchwork.ozlabs.org/api/patches/811392/comments/","check":"pending","checks":"http://patchwork.ozlabs.org/api/patches/811392/checks/","tags":{},"related":[],"headers":{"Return-Path":"","X-Original-To":"incoming@patchwork.ozlabs.org","Delivered-To":["patchwork-incoming@bilbo.ozlabs.org","mailing list gcc-patches@gcc.gnu.org"],"Authentication-Results":["ozlabs.org;\n\tspf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org\n\t(client-ip=209.132.180.131; helo=sourceware.org;\n\tenvelope-from=gcc-patches-return-461703-incoming=patchwork.ozlabs.org@gcc.gnu.org;\n\treceiver=)","ozlabs.org; dkim=pass (1024-bit key;\n\tunprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org\n\theader.b=\"qfMUbSfN\"; dkim-atps=neutral","sourceware.org; auth=none"],"Received":["from sourceware.org (server1.sourceware.org [209.132.180.131])\n\t(using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256\n\tbits)) (No client certificate requested)\n\tby ozlabs.org (Postfix) with ESMTPS id 3xpWWF1yCjz9sBZ\n\tfor ;\n\tFri, 8 Sep 2017 19:00:41 +1000 (AEST)","(qmail 101901 invoked by alias); 8 Sep 2017 09:00:29 -0000","(qmail 97527 invoked by uid 89); 8 Sep 2017 09:00:18 -0000","from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by\n\tsourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP;\n\tFri, 08 Sep 2017 09:00:01 +0000","from localhost (localhost.localdomain [127.0.0.1])\tby\n\tfiltered-rock.gnat.com (Postfix) with ESMTP id A8D8656260;\n\tFri, 8 Sep 2017 04:59:59 -0400 (EDT)","from rock.gnat.com ([127.0.0.1])\tby localhost (rock.gnat.com\n\t[127.0.0.1]) (amavisd-new, port 10024)\twith LMTP id\n\tcYkTFzNCrBZB; Fri, 8 Sep 2017 04:59:59 -0400 (EDT)","from tron.gnat.com (tron.gnat.com\n\t[IPv6:2620:20:4000:0:46a8:42ff:fe0e:e294])\tby rock.gnat.com\n\t(Postfix) with ESMTP id 96AC55619D;\n\tFri, 8 Sep 2017 04:59:59 -0400 (EDT)","by tron.gnat.com (Postfix, from userid 4192)\tid 95B1E505;\n\tFri, 8 Sep 2017 04:59:59 -0400 (EDT)"],"DomainKey-Signature":"a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id\n\t:list-unsubscribe:list-archive:list-post:list-help:sender:date\n\t:from:to:cc:subject:message-id:mime-version:content-type; q=dns;\n\ts=default; b=SR6ibYaLC9IjkT54VriC+HhYxxP33ar9g9iiIVjLfW60sV0Zwq\n\t9A1Zieyc5k9WXTYC+BV0oc25vvNBJYkApjDtBh9lvmXxr4xFJwDGuKdkcOSyjOtj\n\tNVpLzWXTaAxYp8Q98vOXSxe1kG3uYg8HHZKQDmEUTAma54cAWtmEPD9NI=","DKIM-Signature":"v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id\n\t:list-unsubscribe:list-archive:list-post:list-help:sender:date\n\t:from:to:cc:subject:message-id:mime-version:content-type; s=\n\tdefault; bh=AU2msAm5uADW7mHZRRbkiLPo0Ow=; b=qfMUbSfNWOMAo0ZR/owh\n\tNMajmatR8kND8YT2y3KTWb8+3sfE1yiWnhoHzX65rZg0NQmwr3xndVgwOoeL0BNP\n\tFRcyM8RbxaF6go9dk9ZYkWdpg49HvVRlAOZY8BdvEihWVb/93IvUQ393hOoeXs3E\n\ttmnvFE5ksCD5i736IuD5LU8=","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","X-Virus-Found":"No","X-Spam-SWARE-Status":"No, score=-11.9 required=5.0 tests=BAYES_00, GIT_PATCH_2,\n\tGIT_PATCH_3, RCVD_IN_DNSWL_NONE, SPF_PASS,\n\tT_FILL_THIS_FORM_SHORT autolearn=ham version=3.3.2\n\tspammy=communication","X-HELO":"rock.gnat.com","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\n\textensions.","Message-ID":"<20170908085959.GA68804@adacore.com>","MIME-Version":"1.0","Content-Type":"multipart/mixed; boundary=\"rwEMma7ioTxnRzrJ\"","Content-Disposition":"inline","User-Agent":"Mutt/1.5.23 (2014-03-12)"},"content":"This patch fixes a loop in the compiler, on an interface conversion from an\ninterface declared as a synchronized private extension to one of its ancestors.\n\ndatabases-instantiations,adb below must compile quietly:\n\n---\npackage body Databases.Generics is\n New_Data_ID : Data_ID_Type := 1;\n\n protected body Database_Type is\n\n procedure Register\n (Data_Name : in Data_Name_Type;\n Data_ID : out Data_ID_Type)\n is\n Tmp_Data_ID : constant Data_ID_Type := New_Data_ID;\n begin\n Data_Names (Data_ID) := Data_Name;\n Data_Objects_Map (Data_ID) := Data_Object'\n (Data => Init_Data,\n Timestamp => Time_First);\n\n New_Data_ID := New_Data_ID + 1;\n\n Data_ID := Tmp_Data_ID;\n end Register;\n\n procedure Set\n (Data_ID : in Data_ID_Type;\n Raw_Data : in UInt8_Array)\n is\n Data : Data_Type with Address => Raw_Data'Address;\n begin\n Set\n (Data_ID => Data_ID,\n Data => Data);\n end Set;\n\n function Get\n (Data_ID : in Data_ID_Type) return UInt8_Array\n is\n Data_Size : constant Natural := Data_Type'Size / 8;\n Data : constant Data_Type := Get (Data_ID);\n Raw_Data : UInt8_Array (1 .. Data_Size) with Address => Data'Address;\n begin\n return Raw_Data;\n end Get;\n\n procedure Set\n (Data_ID : in Data_ID_Type;\n Data : in Data_Type)\n is\n begin\n Data_Objects_Map (Data_ID).Timestamp := Clock;\n Data_Objects_Map (Data_ID).Data := Data;\n end Set;\n\n function Get\n (Data_ID : in Data_ID_Type) return Data_Type is\n begin\n return Data_Objects_Map (Data_ID).Data;\n end Get;\n\n function Get_Timestamp\n (Data_ID : in Data_ID_Type) return Ada.Real_Time.Time is\n begin\n return Data_Objects_Map (Data_ID).Timestamp;\n end Get_Timestamp;\n\n end Database_Type;\n\n function Get_Database_Instance return Database_Access is\n begin\n return Database_Instance'Access;\n end Get_Database_Instance;\n\nend Databases.Generics;\nwith Ada.Real_Time; use Ada.Real_Time;\nwith Databases; use Databases;\ngeneric\n type Data_Type is private;\n -- The data type that should be stored in the database\n\n Init_Data : Data_Type;\n -- The value that should be set just after the data registration\n\n Max_Nb_Data : Positive;\n -- The maximun number of data that can be stored in the database\n\npackage Databases.Generics is\n\n type Typed_Database_Interface is synchronized interface;\n\n function Get\n (Database : Typed_Database_Interface;\n Data_ID : Data_ID_Type) return Data_Type is abstract;\n -- Get the currently set value for given Data_ID\n\n function Get_Timestamp\n (Database : Typed_Database_Interface;\n Data_ID : Data_ID_Type) return Time is abstract;\n\n procedure Set\n (Database : in out Typed_Database_Interface;\n Data_ID : Data_ID_Type;\n Data : Data_Type) is abstract;\n -- Set a value for the given Data_ID\n\n type Database_Type is synchronized new Root_Database_Type\n and Typed_Database_Interface with private;\n type Database_Access is access all Database_Type'Class;\n -- Database types for the given Data_Type.\n\n function Get_Database_Instance return Database_Access;\n -- Return the unique database instance for this package.\nprivate\n type Data_Object is record\n Data : Data_Type;\n Timestamp : Ada.Real_Time.Time;\n end record;\n\n type Data_Object_Array is\n array (Data_ID_Type'First .. Data_ID_Type (Max_Nb_Data)) of Data_Object;\n\n protected type Database_Type is new Root_Database_Type\n and Typed_Database_Interface with\n\n overriding procedure Register\n (Data_Name : in Data_Name_Type;\n Data_ID : out Data_ID_Type);\n\n overriding function Get\n (Data_ID : in Data_ID_Type) return UInt8_Array;\n\n overriding procedure Set\n (Data_ID : in Data_ID_Type;\n Raw_Data : UInt8_Array);\n\n overriding function Get\n (Data_ID : in Data_ID_Type) return Data_Type;\n -- Get the currently set value for given Data_ID\n\n overriding function Get_Timestamp\n (Data_ID : in Data_ID_Type) return Time;\n\n overriding procedure Set\n (Data_ID : in Data_ID_Type;\n Data : in Data_Type);\n -- Set a value for the given Data_ID\n private\n ID : Database_ID_Type := Get_New_Database_ID;\n Data_Objects_Map : Data_Object_Array;\n Data_Names : Data_Name_Array;\n end Database_Type;\n\n Database_Instance : aliased Database_Type;\n\nend Databases.Generics;\npackage body Databases.Instantiations is\n\n procedure Set_Raw_Data\n (Database_ID : Database_ID_Type;\n Data_ID : Data_ID_Type;\n Raw_Data : UInt8_Array) is\n begin\n Databases (Database_ID).Set\n (Data_ID => Data_ID,\n Raw_Data => Raw_Data);\n end Set_Raw_Data;\n\n function Get_Raw_Data\n (Database_ID : Database_ID_Type;\n Data_ID : Data_ID_Type)\n return UInt8_Array\n is\n begin\n return Databases (Database_ID).Get (Data_ID);\n end Get_Raw_Data;\n\nend Databases.Instantiations;\nwith Databases.Generics;\npackage Databases.Instantiations is\n\n procedure Set_Raw_Data\n (Database_ID : Database_ID_Type;\n Data_ID : Data_ID_Type;\n Raw_Data : UInt8_Array);\n -- Should be used by the Communication module.\n\n function Get_Raw_Data\n (Database_ID : Database_ID_Type;\n Data_ID : Data_ID_Type) return UInt8_Array;\n -- Should be used by the Communication module\n\n package Integer_Databases is new Databases.Generics\n (Integer,\n Init_Data => 0,\n Max_Nb_Data => 10);\n\n package Float_Databases is new Databases.Generics\n (Float,\n Init_Data => 0.0,\n Max_Nb_Data => 10);\nprivate\n First_ID : constant Database_ID_Type := Database_ID_Type'First;\n Last_ID : constant Database_ID_Type := Get_Last_Database_ID;\n\n Databases : constant Root_Database_Array (First_ID .. First_ID + 1) :=\n (First_ID => Root_Database_Access\n (Integer_Databases.Get_Database_Instance),\n First_ID + 1 => Root_Database_Access\n (Float_Databases.Get_Database_Instance));\n\nend Databases.Instantiations;\npackage body Databases is\n\n New_DB_ID : Database_ID_Type := 1;\n\n function Get_New_Database_ID return Database_ID_Type\n is\n DB_ID : constant Database_ID_Type := New_DB_ID;\n begin\n New_DB_ID := New_DB_ID + 1;\n\n return DB_ID;\n end Get_New_Database_ID;\n\n function Get_Last_Database_ID return Database_ID_Type is\n begin\n return New_DB_ID;\n end Get_Last_Database_ID;\n\nend Databases;\nwith Interfaces;\npackage Databases is\n\n type UInt8 is new Interfaces.Unsigned_8;\n type UInt8_Array is array (Natural range <>) of UInt8;\n\n subtype Data_Name_Type is String (1 .. 16);\n -- 16-Characters names used to register the data stored in databases\n\n type Database_ID_Type is private;\n -- Non-string based IDs for databases.\n -- Created when creating a new database instance.\n\n type Data_ID_Type is new Positive;\n -- Non-string based IDs for data stored in databases.\n -- Created when registering data in databases.\n\n type Root_Database_Type is synchronized interface;\n type Root_Database_Access is access all Root_Database_Type'Class;\n -- The root abstract type for all databases\n\n procedure Register\n (Database : in out Root_Database_Type;\n Data_Name : Data_Name_Type;\n Data_ID : out Data_ID_Type) is abstract;\n -- Register data to store in the given Database, associating it with\n -- Data_Name.\n -- The returned ID should be used for later transactions.\n\n function Get\n (Database : Root_Database_Type;\n Data_ID : Data_ID_Type) return UInt8_Array is abstract;\n -- Get the currently set value for given Data_ID in a raw data format\n\n procedure Set\n (Database : in out Root_Database_Type;\n Data_ID : Data_ID_Type;\n Raw_Data : UInt8_Array) is abstract;\n -- Set a raw data value for the given Data_ID\n\nprivate\n type Database_ID_Type is new Positive;\n\n type Root_Database_Array is\n array (Database_ID_Type range <>) of Root_Database_Access;\n\n type Data_Name_Array is array (Data_ID_Type'First .. 16) of Data_Name_Type;\n\n function Get_New_Database_ID return Database_ID_Type;\n -- Used to get a new database ID each time a databse is instantiated\n\n function Get_Last_Database_ID return Database_ID_Type;\n -- Return the lastly created database ID\nend Databases;\n\nTested on x86_64-pc-linux-gnu, committed on trunk\n\n2017-09-08 Ed Schonberg \n\n\t* sem_type.adb (Expand_Interface_Conversion): Prevent an infinite\n\tloop on an interface declared as a private extension of another\n\tsynchronized interface.","diff":"Index: sem_type.adb\n===================================================================\n--- sem_type.adb\t(revision 251863)\n+++ sem_type.adb\t(working copy)\n@@ -2947,11 +2947,14 @@\n -- Continue climbing\n \n else\n- -- Use the full-view of private types (if allowed)\n+ -- Use the full-view of private types (if allowed).\n+ -- Guard against infinite loops when full view has same\n+ -- type as parent, as can happen with interface extensions,\n \n if Use_Full_View\n and then Is_Private_Type (Par)\n and then Present (Full_View (Par))\n+ and then Par /= Etype (Full_View (Par))\n then\n Par := Etype (Full_View (Par));\n else\n","prefixes":["Ada"]}