From patchwork Mon Aug 29 14:23:32 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 112067 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 6680AB6F95 for ; Tue, 30 Aug 2011 00:23:52 +1000 (EST) Received: (qmail 15084 invoked by alias); 29 Aug 2011 14:23:49 -0000 Received: (qmail 15071 invoked by uid 22791); 29 Aug 2011 14:23:47 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL,BAYES_00 X-Spam-Check-By: sourceware.org Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Mon, 29 Aug 2011 14:23:33 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 844F62BB037; Mon, 29 Aug 2011 10:23:32 -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 kxL36TTv4dOU; Mon, 29 Aug 2011 10:23:32 -0400 (EDT) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id 69E002BB00E; Mon, 29 Aug 2011 10:23:32 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id 63D2092A55; Mon, 29 Aug 2011 10:23:32 -0400 (EDT) Date: Mon, 29 Aug 2011 10:23:32 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Javier Miranda Subject: [Ada] Ada 2012: Class-wide operations for formal subprograms Message-ID: <20110829142332.GA4453@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) 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 equivalence defined in AI05-0071-1 for formal subprogram matching is extended such that it applies to explicit as well as default actual subprograms. The following test now compiles without errors. package Pack1 is type Root is tagged record F1 : Integer; end record; procedure Oper_1 (X : in out Root); end Pack1; package Pack2 is generic type T(<>) is private; with procedure Oper_1 (X : in out T) is <>; package Gen_Pack is end Gen_Pack; end Pack2; with Pack1; with Pack2; package Pack3 is package Inst3 is new Pack2.Gen_Pack (Pack1.Root, Pack1.Oper_1); package Inst4 is new Pack2.Gen_Pack (Pack1.Root'Class, Pack1.Oper_1); use Pack1; package Inst5 is new Pack2.Gen_Pack (Pack1.Root); package Inst6 is new Pack2.Gen_Pack (Pack1.Root'Class); end Pack3; Command: gcc -c -gnat12 pack3.ads Tested on x86_64-pc-linux-gnu, committed on trunk 2011-08-29 Javier Miranda * sem_ch8.adb (Analyze_Subprogram_Renaming): Complete support for renamings of formal subprograms when the actual for a formal type is class-wide. Index: sem_ch8.adb =================================================================== --- sem_ch8.adb (revision 178236) +++ sem_ch8.adb (working copy) @@ -1634,11 +1634,6 @@ procedure Analyze_Subprogram_Renaming (N : Node_Id) is Formal_Spec : constant Node_Id := Corresponding_Formal_Spec (N); Is_Actual : constant Boolean := Present (Formal_Spec); - - CW_Actual : Boolean := False; - -- True if the renaming is for a defaulted formal subprogram when the - -- actual for a related formal type is class-wide. For AI05-0071. - Inst_Node : Node_Id := Empty; Nam : constant Node_Id := Name (N); New_S : Entity_Id; @@ -1691,6 +1686,11 @@ -- This rule only applies if there is no explicit visible class-wide -- operation at the point of the instantiation. + function Has_Class_Wide_Actual return Boolean; + -- Ada 2012 (AI05-071, AI05-0131): True if N is the renaming for a + -- defaulted formal subprogram when the actual for the controlling + -- formal type is class-wide. + ----------------------------- -- Check_Class_Wide_Actual -- ----------------------------- @@ -1729,7 +1729,7 @@ Next (F); end loop; - if Ekind (Prim_Op) = E_Function then + if Ekind_In (Prim_Op, E_Function, E_Operator) then return Make_Simple_Return_Statement (Loc, Expression => Make_Function_Call (Loc, @@ -1780,6 +1780,7 @@ F := First_Formal (Formal_Spec); while Present (F) loop if Has_Unknown_Discriminants (Etype (F)) + and then not Is_Class_Wide_Type (Etype (F)) and then Is_Class_Wide_Type (Get_Instance_Of (Etype (F))) then Formal_Type := Etype (F); @@ -1791,7 +1792,6 @@ end loop; if Present (Formal_Type) then - CW_Actual := True; -- Create declaration and body for class-wide operation @@ -1893,6 +1893,41 @@ end if; end Check_Null_Exclusion; + --------------------------- + -- Has_Class_Wide_Actual -- + --------------------------- + + function Has_Class_Wide_Actual return Boolean is + F_Nam : Entity_Id; + F_Spec : Entity_Id; + + begin + if Is_Actual + and then Nkind (Nam) in N_Has_Entity + and then Present (Entity (Nam)) + and then Is_Dispatching_Operation (Entity (Nam)) + then + F_Nam := First_Entity (Entity (Nam)); + F_Spec := First_Formal (Formal_Spec); + while Present (F_Nam) + and then Present (F_Spec) + loop + if Is_Controlling_Formal (F_Nam) + and then Has_Unknown_Discriminants (Etype (F_Spec)) + and then not Is_Class_Wide_Type (Etype (F_Spec)) + and then Is_Class_Wide_Type (Get_Instance_Of (Etype (F_Spec))) + then + return True; + end if; + + Next_Entity (F_Nam); + Next_Formal (F_Spec); + end loop; + end if; + + return False; + end Has_Class_Wide_Actual; + ------------------------- -- Original_Subprogram -- ------------------------- @@ -1938,6 +1973,11 @@ end if; end Original_Subprogram; + CW_Actual : constant Boolean := Has_Class_Wide_Actual; + -- Ada 2012 (AI05-071, AI05-0131): True if the renaming is for a + -- defaulted formal subprogram when the actual for a related formal + -- type is class-wide. + -- Start of processing for Analyze_Subprogram_Renaming begin @@ -2058,7 +2098,14 @@ if Is_Actual then Inst_Node := Unit_Declaration_Node (Formal_Spec); - if Is_Entity_Name (Nam) + -- Check whether the renaming is for a defaulted actual subprogram + -- with a class-wide actual. + + if CW_Actual then + New_S := Analyze_Subprogram_Specification (Spec); + Old_S := Check_Class_Wide_Actual; + + elsif Is_Entity_Name (Nam) and then Present (Entity (Nam)) and then not Comes_From_Source (Nam) and then not Is_Overloaded (Nam) @@ -2419,16 +2466,6 @@ end if; end if; - -- If no renamed entity was found, check whether the renaming is for - -- a defaulted actual subprogram with a class-wide actual. - - if Old_S = Any_Id - and then Is_Actual - and then From_Default (N) - then - Old_S := Check_Class_Wide_Actual; - end if; - if Old_S /= Any_Id then if Is_Actual and then From_Default (N) then