From patchwork Thu Oct 7 12:46:06 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 67048 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 7BD97B6F10 for ; Thu, 7 Oct 2010 23:46:28 +1100 (EST) Received: (qmail 30514 invoked by alias); 7 Oct 2010 12:46:23 -0000 Received: (qmail 30450 invoked by uid 22791); 7 Oct 2010 12:46:20 -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; Thu, 07 Oct 2010 12:46:12 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id DC75429000E; Thu, 7 Oct 2010 14:46:06 +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 CN5fSpK2p07W; Thu, 7 Oct 2010 14:46:06 +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 C8D5229000D; Thu, 7 Oct 2010 14:46:06 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id 92FFCD9BB5; Thu, 7 Oct 2010 14:46:06 +0200 (CEST) Date: Thu, 7 Oct 2010 14:46:06 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Implementation of AI05-0073 Message-ID: <20101007124606.GA20914@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 This AI fixes some gaps in the handling of functions with abstract results and with controlling access results. A series of new legality checks apply to such functions, and make illegal some constructs that were legal but useless in Ada2005. Compiling the program below in Ada2012 mode must yield: pack.ads:7:04: function whose access result designates abstract type must be abstract pack.ads:11:04: generic function cannot have abstract result type pack.ads:15:04: generic function cannot have an access result that designates an abstract type pack.ads:20:06: function that returns abstract type must be abstract pack.ads:25:07: function whose access result designates abstract type must be abstract pack.ads:30:13: private function with controlling access result must override visible-part function pack.ads:30:13: move subprogram to the visible part (RM 3.9.3(10)) --- -- AI05-0073 : verify that generic functions cannot return an abstract -- type or an access to an abstract type. package Pack is type Real is tagged null record; type Abstr is abstract tagged null record; function Wrong (X : integer) return access Abstr; -- ERROR generic type T (<>) is abstract tagged private; function Gft (X : T) return T; -- ERROR generic type T (<>) is abstract tagged private; function Gft2 (X : T) return access T; -- ERROR generic type T (<>) is abstract tagged private; package GP is function Ft (X : T) return T; -- ERROR end GP; package Pkg is type T (<>) is abstract tagged private; function Ft (X : in T) return access T; -- ERROR private type T (D : Integer) is tagged null record; end Pkg; private function Create (X : Integer) return access Real; -- ERROR end Pack; --- In addition, there is now a dynamic check that the return value of a function with a controlling access result has the same tag as the designated type of the return specification. The following must compile and execute quietly in Ada2012 mode: -- Ada05-0073: rules on controlling results. If a function has a controlling -- access result, verify that the return value designates an object with the -- same tag as that of the designated return type, pragma Ada_2012; with ada.Tags; use Ada.Tags; procedure Tag_Test is package Pack is type T is tagged null record; function Func (X : Integer) return Access T; type T1 is new T with null record; function Func (X : Integer) return Access T1; Obj1 : aliased T1; end Pack; use Pack; Obj : aliased T; Obj1 : aliased T1; function Get return T'Class is begin return T'Class (Obj1); end; It : aliased T'class := Get; package body Pack is function Func (X : Integer) return Access T is begin if X < 10 then return Obj : access T := It'Access do null; end return; else return It'Access; end if; end Func; function Func (X : Integer) return access T1 is begin return Obj1'access; end; end Pack; Ptr : access T; begin begin Ptr := Func (0); raise Program_Error; -- should not get here exception when Constraint_Error => null; end; begin Ptr := Func (100); raise Program_Error; -- should not get here exception when Constraint_Error => null; end; end Tag_Test; Tested on x86_64-pc-linux-gnu, committed on trunk 2010-10-07 Ed Schonberg * sem_ch6.adb (Analyze_Subprogram_Specification): Implement Ada2012 checks on functions that return an abstract type or have a controlling result whose designated type is an abstract type. (Check_Private_Overriding): Implement Ada2012 checks on functions declared in the private part, if an abstract type is involved. * sem_ch12.adb (Analyze_Generic_Subprogram_Declaration): In Ada2012, reject a generic function that returns an abstract type. * exp_ch5.adb (Expand_Simple_Function_Return): in Ada2012, if a function has a controlling access result, check that the tag of the return value matches the designated type of the return expression. Index: exp_ch5.adb =================================================================== --- exp_ch5.adb (revision 165080) +++ exp_ch5.adb (working copy) @@ -4246,6 +4246,29 @@ package body Exp_Ch5 is Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))), Reason => PE_Accessibility_Check_Failed)); end; + + -- AI05-0073 : if function has a controlling access result, check that + -- the tag of the return value matches the designated type. + + elsif Ekind (R_Type) = E_Anonymous_Access_Type + and then Has_Controlling_Result (Scope_Id) + and then Ada_Version >= Ada_12 + then + Insert_Action (Exp, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr (Exp), + Selector_Name => + Make_Identifier (Loc, Chars => Name_uTag)), + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Designated_Type (R_Type), Loc), + Attribute_Name => Name_Tag)), + Reason => CE_Tag_Check_Failed)); end if; -- If we are returning an object that may not be bit-aligned, then copy Index: sem_ch12.adb =================================================================== --- sem_ch12.adb (revision 165081) +++ sem_ch12.adb (working copy) @@ -2800,10 +2800,28 @@ package body Sem_Ch12 is if Nkind (Result_Definition (Spec)) = N_Access_Definition then Result_Type := Access_Definition (Spec, Result_Definition (Spec)); Set_Etype (Id, Result_Type); + + -- Check restriction imposed by AI05-073 : a generic function + -- cannot return an abstract type or an access to such. + + if Is_Abstract_Type (Designated_Type (Result_Type)) + and then Ada_Version >= Ada_12 + then + Error_Msg_N ("generic function cannot have an access result" + & " that designates an abstract type", Spec); + end if; + else Find_Type (Result_Definition (Spec)); Typ := Entity (Result_Definition (Spec)); + if Is_Abstract_Type (Typ) + and then Ada_Version >= Ada_12 + then + Error_Msg_N + ("generic function cannot have abstract result type", Spec); + end if; + -- If a null exclusion is imposed on the result type, then create -- a null-excluding itype (an access subtype) and use it as the -- function's Etype. Index: sem_ch6.adb =================================================================== --- sem_ch6.adb (revision 165098) +++ sem_ch6.adb (working copy) @@ -2960,16 +2960,29 @@ package body Sem_Ch6 is -- In case of primitives associated with abstract interface types -- the check is applied later (see Analyze_Subprogram_Declaration). - if Is_Abstract_Type (Etype (Designator)) - and then not Is_Interface (Etype (Designator)) - and then Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration - and then Nkind (Parent (N)) /= - N_Abstract_Subprogram_Declaration - and then - (Nkind (Parent (N))) /= N_Formal_Abstract_Subprogram_Declaration + if not Nkind_In (Parent (N), + N_Subprogram_Renaming_Declaration, + N_Abstract_Subprogram_Declaration, + N_Formal_Abstract_Subprogram_Declaration) then - Error_Msg_N - ("function that returns abstract type must be abstract", N); + if Is_Abstract_Type (Etype (Designator)) + and then not Is_Interface (Etype (Designator)) + then + Error_Msg_N + ("function that returns abstract type must be abstract", N); + + -- Ada 2012 (AI-0073) : extend this test to subprograms with an + -- access result whose designated type is abstract. + + elsif Nkind (Result_Definition (N)) = N_Access_Definition + and then + not Is_Class_Wide_Type (Designated_Type (Etype (Designator))) + and then Is_Abstract_Type (Designated_Type (Etype (Designator))) + and then Ada_Version >= Ada_12 + then + Error_Msg_N ("function whose access result designates " + & "abstract type must be abstract", N); + end if; end if; end if; @@ -7029,16 +7042,34 @@ package body Sem_Ch6 is & "(RM 3.9.3(10))!", S); elsif Ekind (S) = E_Function - and then Is_Tagged_Type (T) - and then T = Base_Type (Etype (S)) and then not Is_Overriding then - Error_Msg_N - ("private function with tagged result must" - & " override visible-part function", S); - Error_Msg_N - ("\move subprogram to the visible part" - & " (RM 3.9.3(10))", S); + if Is_Tagged_Type (T) + and then T = Base_Type (Etype (S)) + then + Error_Msg_N + ("private function with tagged result must" + & " override visible-part function", S); + Error_Msg_N + ("\move subprogram to the visible part" + & " (RM 3.9.3(10))", S); + + -- AI05-0073: extend this test to the case of a function + -- with a controlling access result. + + elsif Ekind (Etype (S)) = E_Anonymous_Access_Type + and then Is_Tagged_Type (Designated_Type (Etype (S))) + and then + not Is_Class_Wide_Type (Designated_Type (Etype (S))) + and then Ada_Version >= Ada_12 + then + Error_Msg_N + ("private function with controlling access result " + & "must override visible-part function", S); + Error_Msg_N + ("\move subprogram to the visible part" + & " (RM 3.9.3(10))", S); + end if; end if; end if; end Check_Private_Overriding;