diff options
Diffstat (limited to 'gcc/ada/sem_cat.adb')
| -rw-r--r-- | gcc/ada/sem_cat.adb | 186 |
1 files changed, 55 insertions, 131 deletions
diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb index 4d1794aeabe..91d731f14b2 100644 --- a/gcc/ada/sem_cat.adb +++ b/gcc/ada/sem_cat.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -37,6 +37,7 @@ with Opt; use Opt; with Sem; use Sem; with Sem_Attr; use Sem_Attr; with Sem_Aux; use Sem_Aux; +with Sem_Dist; use Sem_Dist; with Sem_Eval; use Sem_Eval; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; @@ -160,7 +161,7 @@ package body Sem_Cat is if Is_Pure (E) and then not - (Has_Pragma_Pure_Function (E) and not Has_Pragma_Pure (E)) + (Has_Pragma_Pure_Function (E) and not Has_Pragma_Pure (E)) then return Pure; @@ -213,7 +214,7 @@ package body Sem_Cat is -- to WITH anything in the package body, per (RM E.2(5)). if (Unit_Category = Remote_Types - or else Unit_Category = Remote_Call_Interface) + or else Unit_Category = Remote_Call_Interface) and then In_Package_Body (Unit_Entity) then null; @@ -408,10 +409,10 @@ package body Sem_Cat is function Has_Read_Write_Attributes (E : Entity_Id) return Boolean is begin return True - and then Has_Stream_Attribute_Definition (E, - TSS_Stream_Read, At_Any_Place => True) - and then Has_Stream_Attribute_Definition (E, - TSS_Stream_Write, At_Any_Place => True); + and then Has_Stream_Attribute_Definition + (E, TSS_Stream_Read, At_Any_Place => True) + and then Has_Stream_Attribute_Definition + (E, TSS_Stream_Write, At_Any_Place => True); end Has_Read_Write_Attributes; ------------------------------------- @@ -490,8 +491,8 @@ package body Sem_Cat is Nkind (Unit (Cunit (Current_Sem_Unit))); begin - -- There are no constraints on body of remote_call_interface or - -- remote_types packages. + -- There are no constraints on the body of Remote_Call_Interface or + -- Remote_Types packages. return (Unit_Entity /= Standard_Standard) and then (Is_Preelaborated (Unit_Entity) @@ -499,7 +500,7 @@ package body Sem_Cat is or else Is_Shared_Passive (Unit_Entity) or else ((Is_Remote_Types (Unit_Entity) - or else Is_Remote_Call_Interface (Unit_Entity)) + or else Is_Remote_Call_Interface (Unit_Entity)) and then Ekind (Unit_Entity) = E_Package and then Unit_Kind /= N_Package_Body and then not In_Package_Body (Unit_Entity) @@ -532,8 +533,8 @@ package body Sem_Cat is and then Is_Package_Or_Generic_Package (Unit_Entity) and then Unit_Kind /= N_Package_Body and then List_Containing (N) = - Visible_Declarations - (Specification (Unit_Declaration_Node (Unit_Entity))) + Visible_Declarations + (Specification (Unit_Declaration_Node (Unit_Entity))) and then not In_Package_Body (Unit_Entity) and then not In_Instance; @@ -694,9 +695,7 @@ package body Sem_Cat is PN : Node_Id; begin - if Is_Child_Unit (S) - and then Is_Generic_Instance (S) - then + if Is_Child_Unit (S) and then Is_Generic_Instance (S) then Set_Parents (True); end if; @@ -721,9 +720,7 @@ package body Sem_Cat is Next (PN); end loop; - if Is_Child_Unit (S) - and then Is_Generic_Instance (S) - then + if Is_Child_Unit (S) and then Is_Generic_Instance (S) then Set_Parents (False); end if; end; @@ -738,24 +735,23 @@ package body Sem_Cat is Specification : Node_Id := Empty; begin - Set_Is_Pure (E, - Is_Pure (Scop) and then Is_Library_Level_Entity (E)); + Set_Is_Pure + (E, Is_Pure (Scop) and then Is_Library_Level_Entity (E)); if not Is_Remote_Call_Interface (E) then if Ekind (E) in Subprogram_Kind then Declaration := Unit_Declaration_Node (E); - if Nkind (Declaration) = N_Subprogram_Body - or else - Nkind (Declaration) = N_Subprogram_Renaming_Declaration + if Nkind_In (Declaration, N_Subprogram_Body, + N_Subprogram_Renaming_Declaration) then Specification := Corresponding_Spec (Declaration); end if; end if; - -- A subprogram body or renaming-as-body is a remote call - -- interface if it serves as the completion of a subprogram - -- declaration that is a remote call interface. + -- A subprogram body or renaming-as-body is a remote call interface + -- if it serves as the completion of a subprogram declaration that + -- is a remote call interface. if Nkind (Specification) in N_Entity then Set_Is_Remote_Call_Interface @@ -769,14 +765,14 @@ package body Sem_Cat is Set_Is_Remote_Call_Interface (E, Is_Remote_Call_Interface (Scop) and then not (In_Private_Part (Scop) - or else In_Package_Body (Scop))); + or else In_Package_Body (Scop))); end if; end if; Set_Is_Remote_Types (E, Is_Remote_Types (Scop) and then not (In_Private_Part (Scop) - or else In_Package_Body (Scop))); + or else In_Package_Body (Scop))); end Set_Categorization_From_Scope; ------------------------------ @@ -874,7 +870,7 @@ package body Sem_Cat is if Comes_From_Source (T) and then not (In_Package_Body (Scope (T)) - or else In_Private_Part (Scope (T))) + or else In_Private_Part (Scope (T))) then Set_Is_Remote_Call_Interface (T, Is_Remote_Call_Interface (Scope (T))); @@ -955,8 +951,7 @@ package body Sem_Cat is -- Body of RCI unit does not need validation if Is_Remote_Call_Interface (E) - and then (Nkind (N) = N_Package_Body - or else Nkind (N) = N_Subprogram_Body) + and then Nkind_In (N, N_Package_Body, N_Subprogram_Body) then return; end if; @@ -972,16 +967,16 @@ package body Sem_Cat is while Present (Item) loop if Nkind (Item) = N_With_Clause and then not (Implicit_With (Item) - or else Limited_Present (Item) + or else Limited_Present (Item) - -- Skip if error already posted on the WITH - -- clause (in which case the Name attribute - -- may be invalid). In particular, this fixes - -- the problem of hanging in the presence of a - -- WITH clause on a child that is an illegal - -- generic instantiation. + -- Skip if error already posted on the WITH + -- clause (in which case the Name attribute + -- may be invalid). In particular, this fixes + -- the problem of hanging in the presence of a + -- WITH clause on a child that is an illegal + -- generic instantiation. - or else Error_Posted (Item)) + or else Error_Posted (Item)) then Entity_Of_Withed := Entity (Name (Item)); Check_Categorization_Dependencies @@ -1297,9 +1292,7 @@ package body Sem_Cat is PEE : Node_Id; begin - if Has_Discriminants (ET) - and then Present (EE) - then + if Has_Discriminants (ET) and then Present (EE) then PEE := Parent (EE); if Nkind (PEE) = N_Full_Type_Declaration @@ -1424,7 +1417,7 @@ package body Sem_Cat is -- Check that the return type supports external streaming elsif No_External_Streaming (Rtyp) - and then not Error_Posted (Rtyp) + and then not Error_Posted (Rtyp) then Illegal_Remote_Subp ("return type containing non-remote access " & "must have Read and Write attributes", @@ -1661,70 +1654,16 @@ package body Sem_Cat is ---------------------------------------------------- procedure Validate_Remote_Access_Object_Type_Declaration (T : Entity_Id) is - - function Is_Valid_Remote_Object_Type (E : Entity_Id) return Boolean; - -- True if tagged type E is a valid candidate as the root type of the - -- designated type for a RACW, i.e. a tagged limited private type, or a - -- limited interface type, or a private extension of such a type. - - --------------------------------- - -- Is_Valid_Remote_Object_Type -- - --------------------------------- - - function Is_Valid_Remote_Object_Type (E : Entity_Id) return Boolean is - P : constant Node_Id := Parent (E); - - begin - pragma Assert (Is_Tagged_Type (E)); - - -- Simple case: a limited private type - - if Nkind (P) = N_Private_Type_Declaration - and then Is_Limited_Record (E) - then - return True; - - -- AI05-0060 (Binding Interpretation): A limited interface is a legal - -- ancestor for the designated type of an RACW type. - - elsif Is_Limited_Record (E) and then Is_Limited_Interface (E) then - return True; - - -- A generic tagged limited type is a valid candidate. Limitedness - -- will be checked again on the actual at instantiation point. - - elsif Nkind (P) = N_Formal_Type_Declaration - and then Ekind (E) = E_Record_Type_With_Private - and then Is_Generic_Type (E) - and then Is_Limited_Record (E) - then - return True; - - -- A private extension declaration is a valid candidate if its parent - -- type is. - - elsif Nkind (P) = N_Private_Extension_Declaration then - return Is_Valid_Remote_Object_Type (Etype (E)); - - else - return False; - end if; - end Is_Valid_Remote_Object_Type; - - -- Local variables - Direct_Designated_Type : Entity_Id; Desig_Type : Entity_Id; - -- Start of processing for Validate_Remote_Access_Object_Type_Declaration - begin -- We are called from Analyze_Full_Type_Declaration, and the Nkind of -- the given node is N_Access_To_Object_Definition. if not Comes_From_Source (T) or else (not In_RCI_Declaration (Parent (T)) - and then not In_RT_Declaration) + and then not In_RT_Declaration) then return; end if; @@ -1793,18 +1732,16 @@ package body Sem_Cat is -- The actual parameter of generic instantiation must not be such a -- type if the formal parameter is of an access type. - -- On entry, there are five cases + -- On entry, there are several cases: -- 1. called from sem_attr Analyze_Attribute where attribute name is -- either Storage_Pool or Storage_Size. -- 2. called from exp_ch4 Expand_N_Allocator - -- 3. called from sem_ch12 Analyze_Associations - - -- 4. called from sem_ch4 Analyze_Explicit_Dereference + -- 3. called from sem_ch4 Analyze_Explicit_Dereference - -- 5. called from sem_res Resolve_Actuals + -- 4. called from sem_res Resolve_Actuals if K = N_Attribute_Reference then E := Etype (Prefix (N)); @@ -1822,14 +1759,6 @@ package body Sem_Cat is return; end if; - elsif K in N_Has_Entity then - E := Entity (N); - - if Is_Remote_Access_To_Class_Wide_Type (E) then - Error_Msg_N ("incorrect remote type generic actual", N); - return; - end if; - -- This subprogram also enforces the checks in E.2.2(13). A value of -- such type must not be dereferenced unless as controlling operand of -- a dispatching call. Explicit dereferences not coming from source are @@ -1854,9 +1783,7 @@ package body Sem_Cat is -- If we have a true dereference that comes from source and that -- is a controlling argument for a dispatching call, accept it. - if Is_Actual_Parameter (N) - and then Is_Controlling_Actual (N) - then + if Is_Actual_Parameter (N) and then Is_Controlling_Actual (N) then return; end if; @@ -1866,8 +1793,7 @@ package body Sem_Cat is -- apply in the case of dereference that is the prefix of a selected -- component, which can be a call given in prefixed form. - if (Is_Actual_Parameter (N) - or else PK = N_Selected_Component) + if (Is_Actual_Parameter (N) or else PK = N_Selected_Component) and then not Analyzed (N) then return; @@ -1985,9 +1911,8 @@ package body Sem_Cat is -- partition (E.2.2(8)). if (Ada_Version < Ada_2005 and then Has_Non_Remote_Access (U_Typ)) - or else - (Stream_Attributes_Available (Typ) - and then No_External_Streaming (U_Typ)) + or else (Stream_Attributes_Available (Typ) + and then No_External_Streaming (U_Typ)) then if Is_Non_Remote_Access_Type (Typ) then Error_Msg_N ("error in non-remote access type", U_Typ); @@ -2021,8 +1946,8 @@ package body Sem_Cat is Direct_Designated_Type : Entity_Id; function Has_Entry_Declarations (E : Entity_Id) return Boolean; - -- Return true if the protected type designated by T has - -- entry declarations. + -- Return true if the protected type designated by T has entry + -- declarations. ---------------------------- -- Has_Entry_Declarations -- @@ -2197,16 +2122,15 @@ package body Sem_Cat is and then Enclosing_Lib_Unit_Node (N) /= Enclosing_Lib_Unit_Node (E) and then (Is_Preelaborated (Scope (E)) - or else Is_Pure (Scope (E)) - or else (Present (Renamed_Object (E)) - and then - Is_Entity_Name (Renamed_Object (E)) - and then - (Is_Preelaborated - (Scope (Renamed_Object (E))) - or else - Is_Pure (Scope - (Renamed_Object (E)))))) + or else Is_Pure (Scope (E)) + or else (Present (Renamed_Object (E)) + and then Is_Entity_Name (Renamed_Object (E)) + and then + (Is_Preelaborated + (Scope (Renamed_Object (E))) + or else + Is_Pure (Scope + (Renamed_Object (E)))))) then null; |