From: charlet Date: Tue, 14 Aug 2007 08:49:06 +0000 (+0000) Subject: 2007-08-14 Javier Miranda X-Git-Tag: upstream/4.9.2~46932 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=80e0bd0740b3fa99dade8476bb8bb6839dcf2607;p=platform%2Fupstream%2Flinaro-gcc.git 2007-08-14 Javier Miranda * sem_ch9.adb (Check_Interfaces): New subprogram that factorizes code that is common to Analyze_Protected_Type and Analyze_Task_Type. In case of private types add missing check on matching interfaces in the partial and full declarations. (Analyze_Protected_Type): Code cleanup. (Analyze_Task_Type): Code cleanup. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@127458 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 65d0e82..b4cfe8a 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -70,6 +70,10 @@ package body Sem_Ch9 is -- count the entries (checking the static requirement), and compare with -- the given maximum. + procedure Check_Interfaces (N : Node_Id; T : Entity_Id); + -- N is an N_Protected_Type_Declaration or N_Task_Type_Declaration node. + -- Complete decoration of T and check legality of the covered interfaces. + function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id; -- Find entity in corresponding task or protected declaration. Use full -- view if first declaration was for an incomplete type. @@ -401,8 +405,9 @@ package body Sem_Ch9 is -- Set Never_Set_In_Source and clear Is_True_Constant/Current_Value -- fields on all entry formals (this loop ignores all other entities). - -- Reset Referenced and Has_Pragma_Unreferenced as well, so that we can - -- post accurate warnings on each accept statement for the same entry. + -- Reset Referenced, Referenced_As_LHS and Has_Pragma_Unreferenced as + -- well, so that we can post accurate warnings on each accept statement + -- for the same entry. E := First_Entity (Entry_Nam); while Present (E) loop @@ -411,6 +416,7 @@ package body Sem_Ch9 is Set_Is_True_Constant (E, False); Set_Current_Value (E, Empty); Set_Referenced (E, False); + Set_Referenced_As_LHS (E, False); Set_Has_Pragma_Unreferenced (E, False); end if; @@ -476,7 +482,7 @@ package body Sem_Ch9 is else Error_Msg_N ("dispatching operation of limited or synchronized " & - "interface required ('R'M 9.7.2(3))!", N); + "interface required (RM 9.7.2(3))!", N); end if; end if; end if; @@ -844,6 +850,11 @@ package body Sem_Ch9 is if Present (Index) then Analyze (Index); + + -- The entry index functions like a loop variable, thus it is known + -- to have a valid value. + + Set_Is_Known_Valid (Defining_Identifier (Index)); end if; if Present (Formals) then @@ -1100,11 +1111,9 @@ package body Sem_Ch9 is ---------------------------- procedure Analyze_Protected_Type (N : Node_Id) is - E : Entity_Id; - T : Entity_Id; - Def_Id : constant Entity_Id := Defining_Identifier (N); - Iface : Node_Id; - Iface_Typ : Entity_Id; + Def_Id : constant Entity_Id := Defining_Identifier (N); + E : Entity_Id; + T : Entity_Id; begin if No_Run_Time_Mode then @@ -1130,71 +1139,8 @@ package body Sem_Ch9 is Set_Stored_Constraint (T, No_Elist); Push_Scope (T); - -- Ada 2005 (AI-345) - - if Present (Interface_List (N)) then - Set_Is_Tagged_Type (T); - - Iface := First (Interface_List (N)); - while Present (Iface) loop - Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); - - if not Is_Interface (Iface_Typ) then - Error_Msg_NE ("(Ada 2005) & must be an interface", - Iface, Iface_Typ); - - else - -- Ada 2005 (AI-251): "The declaration of a specific descendant - -- of an interface type freezes the interface type" RM 13.14. - - Freeze_Before (N, Etype (Iface)); - - -- Ada 2005 (AI-345): Protected types can only implement - -- limited, synchronized, or protected interfaces (note that - -- the predicate Is_Limited_Interface includes synchronized - -- and protected interfaces). - - if Is_Task_Interface (Iface_Typ) then - Error_Msg_N ("(Ada 2005) protected type cannot implement a " - & "task interface", Iface); - - elsif not Is_Limited_Interface (Iface_Typ) then - Error_Msg_N ("(Ada 2005) protected type cannot implement a " - & "non-limited interface", Iface); - end if; - end if; - - Next (Iface); - end loop; - - -- If this is the full-declaration associated with a private - -- declaration that implement interfaces, then the private type - -- declaration must be limited. - - if Has_Private_Declaration (T) then - declare - E : Entity_Id; - - begin - E := First_Entity (Scope (T)); - loop - pragma Assert (Present (E)); - - if Is_Type (E) and then Present (Full_View (E)) then - exit when Full_View (E) = T; - end if; - - Next_Entity (E); - end loop; - - if not Is_Limited_Record (E) then - Error_Msg_Sloc := Sloc (E); - Error_Msg_N - ("(Ada 2005) private type declaration # must be limited", - T); - end if; - end; - end if; + if Ada_Version >= Ada_05 then + Check_Interfaces (N, T); end if; if Present (Discriminant_Specifications (N)) then @@ -1907,10 +1853,8 @@ package body Sem_Ch9 is ----------------------- procedure Analyze_Task_Type (N : Node_Id) is - T : Entity_Id; - Def_Id : constant Entity_Id := Defining_Identifier (N); - Iface : Node_Id; - Iface_Typ : Entity_Id; + Def_Id : constant Entity_Id := Defining_Identifier (N); + T : Entity_Id; begin Check_Restriction (No_Tasking, N); @@ -1932,71 +1876,8 @@ package body Sem_Ch9 is Set_Stored_Constraint (T, No_Elist); Push_Scope (T); - -- Ada 2005 (AI-345) - - if Present (Interface_List (N)) then - Set_Is_Tagged_Type (T); - - Iface := First (Interface_List (N)); - while Present (Iface) loop - Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); - - if not Is_Interface (Iface_Typ) then - Error_Msg_NE ("(Ada 2005) & must be an interface", - Iface, Iface_Typ); - - else - -- Ada 2005 (AI-251): The declaration of a specific descendant - -- of an interface type freezes the interface type (RM 13.14). - - Freeze_Before (N, Etype (Iface)); - - -- Ada 2005 (AI-345): Task types can only implement limited, - -- synchronized, or task interfaces (note that the predicate - -- Is_Limited_Interface includes synchronized and task - -- interfaces). - - if Is_Protected_Interface (Iface_Typ) then - Error_Msg_N ("(Ada 2005) task type cannot implement a " & - "protected interface", Iface); - - elsif not Is_Limited_Interface (Iface_Typ) then - Error_Msg_N ("(Ada 2005) task type cannot implement a " & - "non-limited interface", Iface); - end if; - end if; - - Next (Iface); - end loop; - - -- If this is the full-declaration associated with a private - -- declaration that implement interfaces, then the private - -- type declaration must be limited. - - if Has_Private_Declaration (T) then - declare - E : Entity_Id; - - begin - E := First_Entity (Scope (T)); - loop - pragma Assert (Present (E)); - - if Is_Type (E) and then Present (Full_View (E)) then - exit when Full_View (E) = T; - end if; - - Next_Entity (E); - end loop; - - if not Is_Limited_Record (E) then - Error_Msg_Sloc := Sloc (E); - Error_Msg_N - ("(Ada 2005) private type declaration # must be limited", - T); - end if; - end; - end if; + if Ada_Version >= Ada_05 then + Check_Interfaces (N, T); end if; if Present (Discriminant_Specifications (N)) then @@ -2224,6 +2105,169 @@ package body Sem_Ch9 is end if; end Check_Max_Entries; + ---------------------- + -- Check_Interfaces -- + ---------------------- + + procedure Check_Interfaces (N : Node_Id; T : Entity_Id) is + Iface : Node_Id; + Iface_Typ : Entity_Id; + + begin + pragma Assert (Nkind (N) = N_Protected_Type_Declaration + or else Nkind (N) = N_Task_Type_Declaration); + + if Present (Interface_List (N)) then + Set_Is_Tagged_Type (T); + + Iface := First (Interface_List (N)); + while Present (Iface) loop + Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); + + if not Is_Interface (Iface_Typ) then + Error_Msg_NE + ("(Ada 2005) & must be an interface", Iface, Iface_Typ); + + else + -- Ada 2005 (AI-251): "The declaration of a specific descendant + -- of an interface type freezes the interface type" RM 13.14. + + Freeze_Before (N, Etype (Iface)); + + if Nkind (N) = N_Protected_Type_Declaration then + + -- Ada 2005 (AI-345): Protected types can only implement + -- limited, synchronized, or protected interfaces (note that + -- the predicate Is_Limited_Interface includes synchronized + -- and protected interfaces). + + if Is_Task_Interface (Iface_Typ) then + Error_Msg_N ("(Ada 2005) protected type cannot implement " + & "a task interface", Iface); + + elsif not Is_Limited_Interface (Iface_Typ) then + Error_Msg_N ("(Ada 2005) protected type cannot implement " + & "a non-limited interface", Iface); + end if; + + else pragma Assert (Nkind (N) = N_Task_Type_Declaration); + + -- Ada 2005 (AI-345): Task types can only implement limited, + -- synchronized, or task interfaces (note that the predicate + -- Is_Limited_Interface includes synchronized and task + -- interfaces). + + if Is_Protected_Interface (Iface_Typ) then + Error_Msg_N ("(Ada 2005) task type cannot implement a " & + "protected interface", Iface); + + elsif not Is_Limited_Interface (Iface_Typ) then + Error_Msg_N ("(Ada 2005) task type cannot implement a " & + "non-limited interface", Iface); + end if; + end if; + end if; + + Next (Iface); + end loop; + end if; + + if not Has_Private_Declaration (T) then + return; + end if; + + -- Additional checks on full-types associated with private type + -- declarations. Search for the private type declaration. + + declare + Full_T_Ifaces : Elist_Id; + Iface : Node_Id; + Priv_T : Entity_Id; + Priv_T_Ifaces : Elist_Id; + + begin + Priv_T := First_Entity (Scope (T)); + loop + pragma Assert (Present (Priv_T)); + + if Is_Type (Priv_T) and then Present (Full_View (Priv_T)) then + exit when Full_View (Priv_T) = T; + end if; + + Next_Entity (Priv_T); + end loop; + + -- In case of synchronized types covering interfaces the private type + -- declaration must be limited. + + if Present (Interface_List (N)) + and then not Is_Limited_Record (Priv_T) + then + Error_Msg_Sloc := Sloc (Priv_T); + Error_Msg_N ("(Ada 2005) limited type declaration expected for " & + "private type#", T); + end if; + + -- RM 7.3 (7.1/2): If the full view has a partial view that is + -- tagged then check RM 7.3 subsidiary rules. + + if Is_Tagged_Type (Priv_T) + and then not Error_Posted (N) + then + -- RM 7.3 (7.2/2): The partial view shall be a synchronized tagged + -- type if and only if the full type is a synchronized tagged type + + if Is_Synchronized_Tagged_Type (Priv_T) + and then not Is_Synchronized_Tagged_Type (T) + then + Error_Msg_N + ("(Ada 2005) full view must be a synchronized tagged " & + "type ('R'M 7.3 (7.2/2))", Priv_T); + + elsif Is_Synchronized_Tagged_Type (T) + and then not Is_Synchronized_Tagged_Type (Priv_T) + then + Error_Msg_N + ("(Ada 2005) partial view must be a synchronized tagged " & + "type ('R'M 7.3 (7.2/2))", T); + end if; + + -- RM 7.3 (7.3/2): The partial view shall be a descendant of an + -- interface type if and only if the full type is descendant of + -- the interface type. + + if Present (Interface_List (N)) + or else (Is_Tagged_Type (Priv_T) + and then Has_Abstract_Interfaces + (Priv_T, Use_Full_View => False)) + then + if Is_Tagged_Type (Priv_T) then + Collect_Abstract_Interfaces + (Priv_T, Priv_T_Ifaces, Use_Full_View => False); + end if; + + if Is_Tagged_Type (T) then + Collect_Abstract_Interfaces (T, Full_T_Ifaces); + end if; + + Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); + + if Present (Iface) then + Error_Msg_NE ("interface & not implemented by full type " & + "(RM-2005 7.3 (7.3/2))", Priv_T, Iface); + end if; + + Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces); + + if Present (Iface) then + Error_Msg_NE ("interface & not implemented by partial " & + "view (RM-2005 7.3 (7.3/2))", T, Iface); + end if; + end if; + end if; + end; + end Check_Interfaces; + -------------------------- -- Find_Concurrent_Spec -- --------------------------