diff options
Diffstat (limited to 'gcc/ada/sem_cat.adb')
| -rw-r--r-- | gcc/ada/sem_cat.adb | 187 |
1 files changed, 101 insertions, 86 deletions
diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb index 3360f6e5db7..bb33f4cf27f 100644 --- a/gcc/ada/sem_cat.adb +++ b/gcc/ada/sem_cat.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2003, 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- -- @@ -34,6 +34,7 @@ with Fname; use Fname; with Lib; use Lib; with Nlists; use Nlists; with Sem; use Sem; +with Sem_Eval; use Sem_Eval; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; @@ -93,7 +94,7 @@ package body Sem_Cat is -- a preelaborated library unit. procedure Validate_Remote_Access_Object_Type_Declaration (T : Entity_Id); - -- Check validity of declaration if RCI unit. It should not contain + -- Check validity of declaration if RCI or RT unit. It should not contain -- the declaration of an access-to-object type unless it is a -- general access type that designates a class-wide limited -- private type. There are also constraints about the primitive @@ -114,7 +115,7 @@ package body Sem_Cat is Info_Node : Node_Id; Is_Subunit : Boolean) is - N : Node_Id := Info_Node; + N : constant Node_Id := Info_Node; type Categorization is (Pure, Shared_Passive, Remote_Types, @@ -127,6 +128,10 @@ package body Sem_Cat is -- Check categorization flags from entity, and return in the form -- of a corresponding enumeration value. + ------------------------ + -- Get_Categorization -- + ------------------------ + function Get_Categorization (E : Entity_Id) return Categorization is begin if Is_Preelaborated (E) then @@ -220,8 +225,8 @@ package body Sem_Cat is and then not Is_Static_Expression (Expression (Component_Decl)) then Error_Msg_Sloc := Sloc (Component_Decl); - Error_Msg_N - ("object in preelaborated unit has nonstatic default#", + Error_Msg_F + ("object in preelaborated unit has non-static default#", Obj_Decl); -- Fix this later ??? @@ -333,7 +338,6 @@ package body Sem_Cat is function In_Subprogram_Task_Protected_Unit return Boolean is E : Entity_Id; - K : Entity_Kind; begin -- The following is to verify that a declaration is inside @@ -344,16 +348,11 @@ package body Sem_Cat is E := Current_Scope; loop - K := Ekind (E); - - if K = E_Procedure - or else K = E_Function - or else K = E_Generic_Procedure - or else K = E_Generic_Function - or else K = E_Task_Type - or else K = E_Task_Subtype - or else K = E_Protected_Type - or else K = E_Protected_Subtype + if Is_Subprogram (E) + or else + Is_Generic_Subprogram (E) + or else + Is_Concurrent_Type (E) then return True; @@ -363,7 +362,6 @@ package body Sem_Cat is E := Scope (E); end loop; - end In_Subprogram_Task_Protected_Unit; ------------------------------- @@ -546,10 +544,59 @@ package body Sem_Cat is end; end Set_Categorization_From_Pragmas; + ----------------------------------- + -- Set_Categorization_From_Scope -- + ----------------------------------- + + procedure Set_Categorization_From_Scope (E : Entity_Id; Scop : Entity_Id) is + Declaration : Node_Id := Empty; + Specification : Node_Id := Empty; + + begin + 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 False + or else Nkind (Declaration) = N_Subprogram_Body + or else Nkind (Declaration) = 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. + + if Nkind (Specification) in N_Entity then + Set_Is_Remote_Call_Interface + (E, Is_Remote_Call_Interface (Specification)); + + -- A subprogram declaration is a remote call interface when it is + -- declared within the visible part of, or declared by, a library + -- unit declaration that is a remote call interface. + + else + Set_Is_Remote_Call_Interface + (E, Is_Remote_Call_Interface (Scop) + and then not (In_Private_Part (Scop) + or else In_Package_Body (Scop))); + end if; + end if; + + Set_Is_Remote_Types (E, Is_Remote_Types (Scop)); + end Set_Categorization_From_Scope; + ------------------------------ -- Static_Discriminant_Expr -- ------------------------------ + -- We need to accomodate a Why_Not_Static call somehow here ??? + function Static_Discriminant_Expr (L : List_Id) return Boolean is Discriminant_Spec : Node_Id; @@ -600,9 +647,9 @@ package body Sem_Cat is ("named access type not allowed in pure unit", T); end if; - -- Check for RCI unit type declaration. It should not contain - -- the declaration of an access-to-object type unless it is a - -- general access type that designates a class-wide limited + -- Check for RCI or RT unit type declaration. It should not + -- contain the declaration of an access-to-object type unless it + -- is a general access type that designates a class-wide limited -- private type. There are also constraints about the primitive -- subprograms of the class-wide type. @@ -617,22 +664,18 @@ package body Sem_Cat is when others => null; end case; - -- Set Categorization flag of package on entity as well, to allow - -- easy checks later on for required validations of RCI units. This - -- is only done for entities that are in the original source. - - if Comes_From_Source (T) then - if Is_Remote_Call_Interface (Scope (T)) - and then not In_Package_Body (Scope (T)) - then - Set_Is_Remote_Call_Interface (T); - end if; + -- Set categorization flag from package on entity as well, to allow + -- easy checks later on for required validations of RCI or RT units. + -- This is only done for entities that are in the original source. - if Is_Remote_Types (Scope (T)) - and then not In_Package_Body (Scope (T)) - then - Set_Is_Remote_Types (T); - end if; + if Comes_From_Source (T) + and then not (In_Package_Body (Scope (T)) + or else In_Private_Part (Scope (T))) + then + Set_Is_Remote_Call_Interface + (T, Is_Remote_Call_Interface (Scope (T))); + Set_Is_Remote_Types + (T, Is_Remote_Types (Scope (T))); end if; end Validate_Access_Type_Declaration; @@ -641,8 +684,8 @@ package body Sem_Cat is ---------------------------- procedure Validate_Ancestor_Part (N : Node_Id) is - A : constant Node_Id := Ancestor_Part (N); - T : Entity_Id := Entity (A); + A : constant Node_Id := Ancestor_Part (N); + T : constant Entity_Id := Entity (A); begin if In_Preelaborated_Unit @@ -718,7 +761,7 @@ package body Sem_Cat is return; end if; - -- Process with clauses + -- Process explicit with_clauses that are not limited. declare Item : Node_Id; @@ -729,7 +772,8 @@ package body Sem_Cat is while Present (Item) loop if Nkind (Item) = N_With_Clause - and then not Implicit_With (Item) + and then not (Implicit_With (Item) + or else Limited_Present (Item)) then Entity_Of_Withed := Entity (Name (Item)); Check_Categorization_Dependencies @@ -1053,13 +1097,12 @@ package body Sem_Cat is begin E := First_Entity (P); - while Present (E) loop if Comes_From_Source (E) then - if Is_Limited_Type (E) then Error_Msg_N ("Limited type not allowed in rci unit", Parent (E)); + Explain_Limited_Type (E, Parent (E)); elsif Ekind (E) = E_Generic_Function or else Ekind (E) = E_Generic_Package @@ -1103,7 +1146,7 @@ package body Sem_Cat is ----------------------------------------- procedure Validate_RCI_Subprogram_Declaration (N : Node_Id) is - K : Node_Kind := Nkind (N); + K : constant Node_Kind := Nkind (N); Profile : List_Id; Id : Node_Id; Param_Spec : Node_Id; @@ -1178,7 +1221,6 @@ package body Sem_Cat is and then not (Has_Private_Declaration (Param_Type)) and then Comes_From_Source (N))) then - -- A limited parameter is legal only if user-specified -- Read and Write attributes exist for it. -- second part of RM E.2.3 (14) @@ -1186,7 +1228,7 @@ package body Sem_Cat is if No (Full_View (Param_Type)) and then Ekind (Param_Type) /= E_Record_Type then - -- type does not have completion yet, so if declared in + -- Type does not have completion yet, so if declared in -- in the current RCI scope it is illegal, and will be -- flagged subsequently. return; @@ -1194,10 +1236,10 @@ package body Sem_Cat is Base_Param_Type := Base_Type (Underlying_Type (Param_Type)); - if No (TSS (Base_Param_Type, Name_uRead)) - or else No (TSS (Base_Param_Type, Name_uWrite)) + if No (TSS (Base_Param_Type, TSS_Stream_Read)) + or else + No (TSS (Base_Param_Type, TSS_Stream_Write)) then - if K = N_Subprogram_Declaration then Error_Node := Param_Spec; end if; @@ -1205,6 +1247,7 @@ package body Sem_Cat is Error_Msg_N ("limited parameter in rci unit " & "must have read/write attributes ", Error_Node); + Explain_Limited_Type (Param_Type, Error_Node); end if; end if; @@ -1226,7 +1269,6 @@ package body Sem_Cat is Profile : List_Id; Param_Spec : Node_Id; Param_Type : Entity_Id; - Limited_Type_Decl : Node_Id; begin -- We are called from Analyze_Type_Declaration, and the Nkind @@ -1247,8 +1289,8 @@ package body Sem_Cat is return; end if; - -- Check RCI unit type declaration. It should not contain the - -- declaration of an access-to-object type unless it is a + -- Check RCI or RT unit type declaration. It may not contain + -- the declaration of an access-to-object type unless it is a -- general access type that designates a class-wide limited -- private type. There are also constraints about the primitive -- subprograms of the class-wide type (RM E.2.3(14)). @@ -1269,7 +1311,6 @@ package body Sem_Cat is end if; Direct_Designated_Type := Designated_Type (T); - Desig_Type := Etype (Direct_Designated_Type); if not Is_Recursively_Limited_Private (Desig_Type) then @@ -1326,23 +1367,22 @@ package body Sem_Cat is then -- Not a controlling parameter, so type must have Read -- and Write attributes. - -- ??? I suspect this to be dead code because any violation - -- should be caught before in sem_attr.adb (with the message - -- "limited type ... used in ... has no stream attr."). ST if Nkind (Param_Type) in N_Has_Etype and then Nkind (Parent (Etype (Param_Type))) = N_Private_Type_Declaration then Param_Type := Etype (Param_Type); - Limited_Type_Decl := Parent (Param_Type); - if No (TSS (Param_Type, Name_uRead)) - or else No (TSS (Param_Type, Name_uWrite)) + if No (TSS (Param_Type, TSS_Stream_Read)) + or else + No (TSS (Param_Type, TSS_Stream_Write)) then Error_Msg_N ("limited formal must have Read and Write attributes", Param_Spec); + Explain_Limited_Type + (Etype (Defining_Identifier (Param_Spec)), Param_Spec); end if; end if; end if; @@ -1497,33 +1537,6 @@ package body Sem_Cat is end if; end Validate_Remote_Access_To_Class_Wide_Type; - ----------------------------------------------- - -- Validate_Remote_Access_To_Subprogram_Type -- - ----------------------------------------------- - - procedure Validate_Remote_Access_To_Subprogram_Type (N : Node_Id) is - Type_Def : constant Node_Id := Type_Definition (N); - Current_Parameter : Node_Id; - - begin - if Present (Parameter_Specifications (Type_Def)) then - Current_Parameter := First (Parameter_Specifications (Type_Def)); - while Present (Current_Parameter) loop - if Nkind (Parameter_Type (Current_Parameter)) = - N_Access_Definition - then - Error_Msg_N - ("remote access to subprogram type declaration contains", - Current_Parameter); - Error_Msg_N - ("\parameter of an anonymous access type", Current_Parameter); - end if; - - Current_Parameter := Next (Current_Parameter); - end loop; - end if; - end Validate_Remote_Access_To_Subprogram_Type; - ------------------------------------------ -- Validate_Remote_Type_Type_Conversion -- ------------------------------------------ @@ -1764,7 +1777,8 @@ package body Sem_Cat is or else Present (Enclosing_Generic_Body (N))) then if Ekind (Entity (N)) = E_Variable then - Error_Msg_N ("non-static object name in preelaborated unit", N); + Flag_Non_Static_Expr + ("non-static object name in preelaborated unit", N); -- We take the view that a constant defined in another preelaborated -- unit is preelaborable, even though it may have a private type and @@ -1793,7 +1807,8 @@ package body Sem_Cat is then null; else - Error_Msg_N ("non-static constant in preelaborated unit", N); + Flag_Non_Static_Expr + ("non-static constant in preelaborated unit", N); end if; end if; end if; |