From patchwork Wed Aug 14 09:53:13 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Pierre-Marie de Rodat X-Patchwork-Id: 1146896 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-506908-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=adacore.com Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="i6PPfS7F"; 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 467lLQ4m3Cz9sDQ for ; Wed, 14 Aug 2019 19:54:54 +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=oXeGjlUadbsCf7/ml51aiUpb6wLc25lpfaONzOt1njxrgTsnJo RyZaXi3UvoCidpXpIFTUYPdS8iK26d59uLFXkYs+cdFnkPErhC53cK36bmMwO5hx zDS3Da3GRIj48z+VgTpdEiL4o1IgTIQlAS0VeEC3C5nxLt1qzWVLdedN8= 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=bf8yWPEme5hYyYzOHa/VbcoDpPg=; b=i6PPfS7FSNj2j2m+ZzfW mlQ0PzbrsioThBBA9KxuOESvmnVQRGqubAQyY8LnR5odB4t0lPMWC1deVoe/68+5 HUFlhgfvyHKpd06wAhWcBgzyo1oS0ECJwUAGS3Jf/52kENmw6gzJo7RTwQiIZsaK u+p6mdGwOXxfh9kcF7Jw5xo= Received: (qmail 73934 invoked by alias); 14 Aug 2019 09:53:20 -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 73808 invoked by uid 89); 14 Aug 2019 09:53:19 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-11.1 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_2, GIT_PATCH_3, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.1 spammy=UD:List 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; Wed, 14 Aug 2019 09:53:17 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 876CE5610C; Wed, 14 Aug 2019 05:53:13 -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 GVRPv-4PPGAF; Wed, 14 Aug 2019 05:53:13 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id 7579D11626C; Wed, 14 Aug 2019 05:53:13 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4862) id 743B26CC; Wed, 14 Aug 2019 05:53:13 -0400 (EDT) Date: Wed, 14 Aug 2019 05:53:13 -0400 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Gary Dismukes Subject: [Ada] Equality for nonabstract type derived from interface treated as abstract Message-ID: <20190814095313.GA52287@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-IsSubscribed: yes The compiler was creating an abstract function for the equality operation of a (nonlimited) interface type, and that could result in errors on generic instantiations that are passed nonabstract types derived from the interface type along with the derived type's inherited equality operation (complaining about an abstract subprogram being passed to a nonabstract formal). The "=" operation of an interface is supposed to be nonabstract (a direct consequence of the rule in RM 4.5.2(6-7)), so we now create an expression function rather than an abstract function. The function returns False, but the result is unimportant since a function of an abstract type can never actually be invoked (its arguments must generally be class-wide, since there can be no objects of the type, and calling it will dispatch). Tested on x86_64-pc-linux-gnu, committed on trunk 2019-08-14 Gary Dismukes gcc/ada/ * exp_ch3.adb (Predef_Spec_Or_Body): For an equality operation of an interface type, create an expression function (that returns False) rather than declaring an abstract function. * freeze.adb (Check_Inherited_Conditions): Set Needs_Wrapper to False unconditionally at the start of the loop creating wrappers for inherited operations. gcc/testsuite/ * gnat.dg/equal11.adb, gnat.dg/equal11_interface.ads, gnat.dg/equal11_record.adb, gnat.dg/equal11_record.ads: New testcase. --- gcc/ada/exp_ch3.adb +++ gcc/ada/exp_ch3.adb @@ -10313,8 +10313,24 @@ package body Exp_Ch3 is Result_Definition => New_Occurrence_Of (Ret_Type, Loc)); end if; + -- Declare an abstract subprogram for primitive subprograms of an + -- interface type (except for "="). + if Is_Interface (Tag_Typ) then - return Make_Abstract_Subprogram_Declaration (Loc, Spec); + if Name /= Name_Op_Eq then + return Make_Abstract_Subprogram_Declaration (Loc, Spec); + + -- The equality function (if any) for an interface type is defined + -- to be nonabstract, so we create an expression function for it that + -- always returns False. Note that the function can never actually be + -- invoked because interface types are abstract, so there aren't any + -- objects of such types (and their equality operation will always + -- dispatch). + + else + return Make_Expression_Function + (Loc, Spec, New_Occurrence_Of (Standard_False, Loc)); + end if; -- If body case, return empty subprogram body. Note that this is ill- -- formed, because there is not even a null statement, and certainly not --- gcc/ada/freeze.adb +++ gcc/ada/freeze.adb @@ -1526,11 +1526,11 @@ package body Freeze is -- so that LSP can be verified/enforced. Op_Node := First_Elmt (Prim_Ops); - Needs_Wrapper := False; while Present (Op_Node) loop - Decls := Empty_List; - Prim := Node (Op_Node); + Decls := Empty_List; + Prim := Node (Op_Node); + Needs_Wrapper := False; if not Comes_From_Source (Prim) and then Present (Alias (Prim)) then Par_Prim := Alias (Prim); @@ -1601,8 +1601,6 @@ package body Freeze is (Par_R, New_List (New_Decl, New_Body)); end if; end; - - Needs_Wrapper := False; end if; Next_Elmt (Op_Node); --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/equal11.adb @@ -0,0 +1,37 @@ +-- { dg-do run } + +with Equal11_Record; + +procedure Equal11 is + + use Equal11_Record; + + R : My_Record_Type; + L : My_Record_Type_List_Pck.List; +begin + -- Single record + R.F := 42; + R.Put; + if Put_Result /= 42 then + raise Program_Error; + end if; + + -- List of records + L.Append ((F => 3)); + L.Append ((F => 2)); + L.Append ((F => 1)); + + declare + Expected : constant array (Positive range <>) of Integer := + (3, 2, 1); + I : Positive := 1; + begin + for LR of L loop + LR.Put; + if Put_Result /= Expected (I) then + raise Program_Error; + end if; + I := I + 1; + end loop; + end; +end Equal11; --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/equal11_interface.ads @@ -0,0 +1,7 @@ +package Equal11_Interface is + + type My_Interface_Type is interface; + + procedure Put (R : in My_Interface_Type) is abstract; + +end Equal11_Interface; --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/equal11_record.adb @@ -0,0 +1,10 @@ +with Ada.Text_IO; + +package body Equal11_Record is + + procedure Put (R : in My_Record_Type) is + begin + Put_Result := R.F; + end Put; + +end Equal11_Record; --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/equal11_record.ads @@ -0,0 +1,21 @@ +with Ada.Containers.Doubly_Linked_Lists; +with Equal11_Interface; + +package Equal11_Record is + + use Equal11_Interface; + + type My_Record_Type is new My_Interface_Type with + record + F : Integer; + end record; + + overriding + procedure Put (R : in My_Record_Type); + + Put_Result : Integer; + + package My_Record_Type_List_Pck is + new Ada.Containers.Doubly_Linked_Lists (Element_Type => My_Record_Type); + +end Equal11_Record;