From patchwork Mon Oct 18 13:59:07 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 68192 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 D04D9B710B for ; Tue, 19 Oct 2010 00:59:27 +1100 (EST) Received: (qmail 9148 invoked by alias); 18 Oct 2010 13:59:22 -0000 Received: (qmail 9110 invoked by uid 22791); 18 Oct 2010 13:59:17 -0000 X-SWARE-Spam-Status: No, hits=1.3 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) (194.98.77.210) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Mon, 18 Oct 2010 13:59:10 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id 39966CB0250; Mon, 18 Oct 2010 15:59:08 +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 iULKDqwSss-p; Mon, 18 Oct 2010 15:59:08 +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 1C41FCB0247; Mon, 18 Oct 2010 15:59:08 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id E06ECD9BB4; Mon, 18 Oct 2010 15:59:07 +0200 (CEST) Date: Mon, 18 Oct 2010 15:59:07 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Javier Miranda Subject: [Ada] Ada2012-A162 incomplete type completed by partial view Message-ID: <20101018135907.GA29888@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 patch incorporates the support for this new Ada 2012 feature. Incomplete types are made more useful by allowing them to be completed by private types and private extensions. The following test must compile without errors: package Test_AI162 is type T1; type T2 (X : access T1) is private; type T1 (X : access T2) is private; private type T2 (X : access T1) is record null; end record; type T1 (X : access T2) is record null; end record; end; Command: gcc -c -gnat12 test_ai162.adb Tested on x86_64-pc-linux-gnu, committed on trunk 2010-10-18 Javier Miranda * sem_ch3.ads (Find_Type_Name): Add documentation. * sem_ch3.adb (Analyze_Full_Type_Declaration): Code cleanup because the propagation of the class-wide entity is now done by routine Find_Type_Name to factorize this code. (Analyze_Private_Extension_Declaration): Handle private type that completes an incomplete type. (Tag_Mismatch): Add error message for tag mismatch in a private type declaration that completes an incomplete type. (Find_Type_Name): Handle completion of incomplete type by means of a private declaration. Generate an error if a tagged incomplete type is completed by an untagged private type. * sem_ch7.adb (New_Private_Type): Handle private type that completes an incomplete type. * einfo.ads (Full_View): Add documentation. Index: sem_ch3.adb =================================================================== --- sem_ch3.adb (revision 165618) +++ sem_ch3.adb (working copy) @@ -2171,24 +2171,10 @@ package body Sem_Ch3 is -- imported through a LIMITED WITH clause, it appears as incomplete -- but has no full view. - -- If the incomplete view is tagged, a class_wide type has been - -- created already. Use it for the full view as well, to prevent - -- multiple incompatible class-wide types that may be created for - -- self-referential anonymous access components. - if Ekind (Prev) = E_Incomplete_Type and then Present (Full_View (Prev)) then T := Full_View (Prev); - - if Is_Tagged_Type (Prev) - and then Present (Class_Wide_Type (Prev)) - then - Set_Ekind (T, Ekind (Prev)); -- will be reset later - Set_Class_Wide_Type (T, Class_Wide_Type (Prev)); - Set_Etype (Class_Wide_Type (T), T); - end if; - else T := Prev; end if; @@ -3605,7 +3591,26 @@ package body Sem_Ch3 is end if; Generate_Definition (T); - Enter_Name (T); + + if Ada_Version < Ada_2012 then + Enter_Name (T); + + -- Ada 2012 (AI05-0162): Enter the name in the current scope handling + -- case of private type that completes an incomplete type. + + else + declare + Prev : Entity_Id; + + begin + Prev := Find_Type_Name (N); + + pragma Assert (Prev = T + or else (Ekind (Prev) = E_Incomplete_Type + and then Present (Full_View (Prev)) + and then Full_View (Prev) = T)); + end; + end if; Parent_Type := Find_Type_Of_Subtype_Indic (Indic); Parent_Base := Base_Type (Parent_Type); @@ -14085,11 +14090,25 @@ package body Sem_Ch3 is procedure Tag_Mismatch is begin if Sloc (Prev) < Sloc (Id) then - Error_Msg_NE - ("full declaration of } must be a tagged type ", Id, Prev); + if Ada_Version >= Ada_2012 + and then Nkind (N) = N_Private_Type_Declaration + then + Error_Msg_NE + ("declaration of private } must be a tagged type ", Id, Prev); + else + Error_Msg_NE + ("full declaration of } must be a tagged type ", Id, Prev); + end if; else - Error_Msg_NE - ("full declaration of } must be a tagged type ", Prev, Id); + if Ada_Version >= Ada_2012 + and then Nkind (N) = N_Private_Type_Declaration + then + Error_Msg_NE + ("declaration of private } must be a tagged type ", Prev, Id); + else + Error_Msg_NE + ("full declaration of } must be a tagged type ", Prev, Id); + end if; end if; end Tag_Mismatch; @@ -14100,21 +14119,35 @@ package body Sem_Ch3 is Prev := Current_Entity_In_Scope (Id); - if Present (Prev) then + -- New type declaration + + if No (Prev) then + Enter_Name (Id); + return Id; - -- Previous declaration exists. Error if not incomplete/private case - -- except if previous declaration is implicit, etc. Enter_Name will - -- emit error if appropriate. + -- Previous declaration exists + else Prev_Par := Parent (Prev); + -- Error if not incomplete/private case except if previous + -- declaration is implicit, etc. Enter_Name will emit error if + -- appropriate. + if not Is_Incomplete_Or_Private_Type (Prev) then Enter_Name (Id); New_Id := Id; + -- Check invalid completion of private or incomplete type + elsif not Nkind_In (N, N_Full_Type_Declaration, N_Task_Type_Declaration, N_Protected_Type_Declaration) + and then + (Ada_Version < Ada_2012 + or else not Is_Incomplete_Type (Prev) + or else not Nkind_In (N, N_Private_Type_Declaration, + N_Private_Extension_Declaration)) then -- Completion must be a full type declarations (RM 7.3(4)) @@ -14136,7 +14169,11 @@ package body Sem_Ch3 is -- Case of full declaration of incomplete type - elsif Ekind (Prev) = E_Incomplete_Type then + elsif Ekind (Prev) = E_Incomplete_Type + and then (Ada_Version < Ada_2012 + or else No (Full_View (Prev)) + or else not Is_Private_Type (Full_View (Prev))) + then -- Indicate that the incomplete declaration has a matching full -- declaration. The defining occurrence of the incomplete @@ -14153,9 +14190,34 @@ package body Sem_Ch3 is Set_Is_Internal (Id); New_Id := Prev; + -- If the incomplete view is tagged, a class_wide type has been + -- created already. Use it for the private type as well, in order + -- to prevent multiple incompatible class-wide types that may be + -- created for self-referential anonymous access components. + + if Is_Tagged_Type (Prev) + and then Present (Class_Wide_Type (Prev)) + then + Set_Ekind (Id, Ekind (Prev)); -- will be reset later + Set_Class_Wide_Type (Id, Class_Wide_Type (Prev)); + Set_Etype (Class_Wide_Type (Id), Id); + end if; + -- Case of full declaration of private type else + -- If the private type was a completion of an incomplete type then + -- update Prev to reference the private type + + if Ada_Version >= Ada_2012 + and then Ekind (Prev) = E_Incomplete_Type + and then Present (Full_View (Prev)) + and then Is_Private_Type (Full_View (Prev)) + then + Prev := Full_View (Prev); + Prev_Par := Parent (Prev); + end if; + if Nkind (Parent (Prev)) /= N_Private_Extension_Declaration then if Etype (Prev) /= Prev then @@ -14273,14 +14335,30 @@ package body Sem_Ch3 is if Is_Type (Prev) and then (Is_Tagged_Type (Prev) - or else Present (Class_Wide_Type (Prev))) + or else Present (Class_Wide_Type (Prev))) then + -- Ada 2012 (AI05-0162): A private type may be the completion of + -- an incomplete type + + if Ada_Version >= Ada_2012 + and then Is_Incomplete_Type (Prev) + and then Nkind_In (N, N_Private_Type_Declaration, + N_Private_Extension_Declaration) + then + -- No need to check private extensions since they are tagged + + if Nkind (N) = N_Private_Type_Declaration + and then not Tagged_Present (N) + then + Tag_Mismatch; + end if; + -- The full declaration is either a tagged type (including -- a synchronized type that implements interfaces) or a -- type extension, otherwise this is an error. - if Nkind_In (N, N_Task_Type_Declaration, - N_Protected_Type_Declaration) + elsif Nkind_In (N, N_Task_Type_Declaration, + N_Protected_Type_Declaration) then if No (Interface_List (N)) and then not Error_Posted (N) @@ -14315,12 +14393,6 @@ package body Sem_Ch3 is end if; return New_Id; - - else - -- New type declaration - - Enter_Name (Id); - return Id; end if; end Find_Type_Name; Index: sem_ch3.ads =================================================================== --- sem_ch3.ads (revision 165610) +++ sem_ch3.ads (working copy) @@ -157,7 +157,10 @@ package Sem_Ch3 is function Find_Type_Name (N : Node_Id) return Entity_Id; -- Enter the identifier in a type definition, or find the entity already -- declared, in the case of the full declaration of an incomplete or - -- private type. + -- private type. If the previous declaration is tagged then the class-wide + -- entity is propagated to the identifier to prevent multiple incompatible + -- class-wide types that may be created for self-referential anonymous + -- access components. function Get_Discriminant_Value (Discriminant : Entity_Id; Index: sem_ch7.adb =================================================================== --- sem_ch7.adb (revision 165618) +++ sem_ch7.adb (working copy) @@ -1919,7 +1919,25 @@ package body Sem_Ch7 is procedure New_Private_Type (N : Node_Id; Id : Entity_Id; Def : Node_Id) is begin - Enter_Name (Id); + if Ada_Version < Ada_2012 then + Enter_Name (Id); + + -- Ada 2012 (AI05-0162): Enter the name in the current scope handling + -- private type that completes an incomplete type. + + else + declare + Prev : Entity_Id; + + begin + Prev := Find_Type_Name (N); + + pragma Assert (Prev = Id + or else (Ekind (Prev) = E_Incomplete_Type + and then Present (Full_View (Prev)) + and then Full_View (Prev) = Id)); + end; + end if; if Limited_Present (Def) then Set_Ekind (Id, E_Limited_Private_Type); Index: einfo.ads =================================================================== --- einfo.ads (revision 165634) +++ einfo.ads (working copy) @@ -1283,7 +1283,10 @@ package Einfo is -- Present in all type and subtype entities and in deferred constants. -- References the entity for the corresponding full type declaration. -- For all types other than private and incomplete types, this field --- always contains Empty. See also Underlying_Type. +-- always contains Empty. If an incomplete type E1 is completed by a +-- private type E2 whose full type declaration entity is E3 then the +-- full view of E1 is E2, and the full view of E2 is E3. See also +-- Underlying_Type. -- Generic_Homonym (Node11) -- Present in generic packages. The generic homonym is the entity of