From patchwork Tue Jun 22 16:57:21 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 56531 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id E8E04B742C for ; Wed, 23 Jun 2010 02:57:45 +1000 (EST) Received: (qmail 12876 invoked by alias); 22 Jun 2010 16:57:44 -0000 Received: (qmail 12858 invoked by uid 22791); 22 Jun 2010 16:57:42 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL, BAYES_00, T_RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from mel.act-europe.fr (HELO mel.act-europe.fr) (212.99.106.210) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Tue, 22 Jun 2010 16:57:19 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id 4ED6BCB023D; Tue, 22 Jun 2010 18:57:21 +0200 (CEST) Received: from mel.act-europe.fr ([127.0.0.1]) by localhost (smtp.eu.adacore.com [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id O4FhuJggT9Qy; Tue, 22 Jun 2010 18:57:21 +0200 (CEST) Received: from saumur.act-europe.fr (saumur.act-europe.fr [10.10.0.183]) by mel.act-europe.fr (Postfix) with ESMTP id 3C3C4CB0202; Tue, 22 Jun 2010 18:57:21 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id 3457DD9BB4; Tue, 22 Jun 2010 18:57:21 +0200 (CEST) Date: Tue, 22 Jun 2010 18:57:21 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Javier Miranda Subject: [Ada] Crash overriding the equality operator Message-ID: <20100622165721.GA14363@adacore.com> Mime-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.9i X-IsSubscribed: yes 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 The compiler crashes processing a primitive that overrides the equality operator of a tagged type by means of a function that has a return statement that performs a dispatching call. The following test now compiles silently. package Alpha is type Object is abstract tagged null record; function "=" (L, R : in Object) return Boolean; function Equal (L, R : in Object) return Boolean is abstract; end Alpha; package body Alpha is function "=" (L, R : in Object) return Boolean is begin return Equal (Object'Class (L), Object'Class (R)); -- test end "="; end Alpha; Command: gcc -c -gnat05 alpha.adb Tested on x86_64-pc-linux-gnu, committed on trunk 2010-06-22 Javier Miranda * einfo.ads, einfo.adb (Last_Formal): New synthesized attribute. * exp_util.adb (Find_Prim_Op): Use new attribute to locate the last formal of a primitive. * exp_disp.adb (Is_Predefined_Dispatching_Operation, Is_Predefined_Dispatching_Alias): Use new attribute to locate the last formal of a primitive. * exp_cg.adb (Is_Predefined_Dispatching_Operation): Use new attribute to obtain the last formal of a primitive. Index: exp_util.adb =================================================================== --- exp_util.adb (revision 161137) +++ exp_util.adb (working copy) @@ -1670,7 +1670,7 @@ package body Exp_Util is exit when Chars (Op) = Name and then (Name /= Name_Op_Eq - or else Etype (First_Entity (Op)) = Etype (Last_Entity (Op))); + or else Etype (First_Formal (Op)) = Etype (Last_Formal (Op))); Next_Elmt (Prim); Index: einfo.adb =================================================================== --- einfo.adb (revision 161200) +++ einfo.adb (working copy) @@ -6209,6 +6209,36 @@ package body Einfo is and then Present (Related_Instance (Id))); end Is_Wrapper_Package; + ----------------- + -- Last_Formal -- + ----------------- + + function Last_Formal (Id : E) return E is + Formal : E; + + begin + pragma Assert + (Is_Overloadable (Id) + or else Ekind_In (Id, E_Entry_Family, + E_Subprogram_Body, + E_Subprogram_Type)); + + if Ekind (Id) = E_Enumeration_Literal then + return Empty; + + else + Formal := First_Formal (Id); + + if Present (Formal) then + while Present (Next_Formal (Formal)) loop + Formal := Next_Formal (Formal); + end loop; + end if; + + return Formal; + end if; + end Last_Formal; + -------------------- -- Next_Component -- -------------------- Index: einfo.ads =================================================================== --- einfo.ads (revision 161200) +++ einfo.ads (working copy) @@ -2756,6 +2756,13 @@ package Einfo is -- Points to the last entry in the list of associated entities chained -- through the Next_Entity field. Empty if no entities are chained. +-- Last_Formal (synthesized) +-- Applies to subprograms and subprogram types, and also in entries +-- and entry families. Returns last formal of the subprogram or entry. +-- The formals are the first entities declared in a subprogram or in +-- a subprogram type (the designated type of an Access_To_Subprogram +-- definition) or in an entry. + -- Limited_View (Node23) -- Present in non-generic package entities that are not instances. Bona -- fide package with the limited-view list through the first_entity and @@ -4881,9 +4888,10 @@ package Einfo is -- Sec_Stack_Needed_For_Return (Flag167) -- Uses_Sec_Stack (Flag95) -- Address_Clause (synth) + -- Entry_Index_Type (synth) -- First_Formal (synth) -- First_Formal_With_Extras (synth) - -- Entry_Index_Type (synth) + -- Last_Formal (synth) -- Number_Formals (synth) -- Scope_Depth (synth) @@ -5002,6 +5010,7 @@ package Einfo is -- Address_Clause (synth) -- First_Formal (synth) -- First_Formal_With_Extras (synth) + -- Last_Formal (synth) -- Number_Formals (synth) -- Scope_Depth (synth) @@ -5261,6 +5270,7 @@ package Einfo is -- Address_Clause (synth) -- First_Formal (synth) -- First_Formal_With_Extras (synth) + -- Last_Formal (synth) -- Number_Formals (synth) -- E_Protected_Body @@ -5385,6 +5395,7 @@ package Einfo is -- Directly_Designated_Type (Node20) -- First_Formal (synth) -- First_Formal_With_Extras (synth) + -- Last_Formal (synth) -- Number_Formals (synth) -- (plus type attributes) @@ -6149,6 +6160,7 @@ package Einfo is function Is_Task_Interface (Id : E) return B; function Is_Task_Record_Type (Id : E) return B; function Is_Wrapper_Package (Id : E) return B; + function Last_Formal (Id : E) return E; function Next_Component (Id : E) return E; function Next_Component_Or_Discriminant (Id : E) return E; function Next_Discriminant (Id : E) return E; Index: exp_disp.adb =================================================================== --- exp_disp.adb (revision 161203) +++ exp_disp.adb (working copy) @@ -1782,7 +1782,7 @@ package body Exp_Disp is or else TSS_Name = TSS_Stream_Output or else (Chars (E) = Name_Op_Eq - and then Etype (First_Entity (E)) = Etype (Last_Entity (E))) + and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) or else Chars (E) = Name_uAssign or else TSS_Name = TSS_Deep_Adjust or else TSS_Name = TSS_Deep_Finalize @@ -1824,7 +1824,7 @@ package body Exp_Disp is or else Chars (E) = Name_uAlignment or else (Chars (E) = Name_Op_Eq - and then Etype (First_Entity (E)) = Etype (Last_Entity (E))) + and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) or else Chars (E) = Name_uAssign or else TSS_Name = TSS_Deep_Adjust or else TSS_Name = TSS_Deep_Finalize Index: exp_cg.adb =================================================================== --- exp_cg.adb (revision 161203) +++ exp_cg.adb (working copy) @@ -238,7 +238,7 @@ package body Exp_CG is or else Chars (E) = Name_uAlignment or else (Chars (E) = Name_Op_Eq - and then Etype (First_Entity (E)) = Etype (Last_Entity (E))) + and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) or else Chars (E) = Name_uAssign or else Is_Predefined_Interface_Primitive (E) then @@ -283,7 +283,7 @@ package body Exp_CG is return Predef_Names_95 (J) /= Name_Op_Eq or else - Etype (First_Entity (E)) = Etype (Last_Entity (E)); + Etype (First_Formal (E)) = Etype (Last_Formal (E)); end if; end loop;