From: Robert Dewar Date: Tue, 15 Nov 2005 14:04:10 +0000 (+0100) Subject: sem_util.ads, [...]: Change name Is_Package to Is_Package_Or_Generic_Package. X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=21024a3946b25d19107c51011b2c6897b45bb8b8;p=gcc.git sem_util.ads, [...]: Change name Is_Package to Is_Package_Or_Generic_Package. 2005-11-14 Robert Dewar Thomas Quinot Hristian Kirtchev Ed Schonberg * sem_util.ads, sem_util.adb: Change name Is_Package to Is_Package_Or_Generic_Package. (Check_Obsolescent): New procedure. (Set_Is_Public): Remove obsolete junk test. (Set_Public_Status): Do not set Is_Public on an object whose declaration occurs within a handled_sequence_of_statemets. (Is_Controlling_Limited_Procedure): Factor some of the logic, account for a parameterless procedure. (Enter_Name): Recognize renaming declarations created for private component of a protected type within protected operations, so that the source name of the component can be used in the debugger. From-SVN: r107007 --- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index f2835f67461..25f33b15a6b 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -41,6 +41,8 @@ with Nlists; use Nlists; with Nmake; use Nmake; with Output; use Output; with Opt; use Opt; +with Restrict; use Restrict; +with Rident; use Rident; with Rtsfind; use Rtsfind; with Scans; use Scans; with Scn; use Scn; @@ -863,6 +865,52 @@ package body Sem_Util is end if; end Check_Fully_Declared; + ----------------------- + -- Check_Obsolescent -- + ----------------------- + + procedure Check_Obsolescent (Nam : Entity_Id; N : Node_Id) is + W : Node_Id; + + begin + -- Note that we always allow obsolescent references in the compiler + -- itself and the run time, since we assume that we know what we are + -- doing in such cases. For example the calls in Ada.Characters.Handling + -- to its own obsolescent subprograms are just fine. + + if Is_Obsolescent (Nam) and then not GNAT_Mode then + Check_Restriction (No_Obsolescent_Features, N); + + if Warn_On_Obsolescent_Feature then + if Is_Package_Or_Generic_Package (Nam) then + Error_Msg_NE ("with of obsolescent package&?", N, Nam); + else + Error_Msg_NE ("call to obsolescent subprogram&?", N, Nam); + end if; + + -- Output additional warning if present + + W := Obsolescent_Warning (Nam); + + if Present (W) then + Name_Buffer (1) := '|'; + Name_Buffer (2) := '?'; + Name_Len := 2; + + -- Add characters to message, and output message + + for J in 1 .. String_Length (Strval (W)) loop + Add_Char_To_Name_Buffer ('''); + Add_Char_To_Name_Buffer + (Get_Character (Get_String_Char (Strval (W), J))); + end loop; + + Error_Msg_N (Name_Buffer (1 .. Name_Len), N); + end if; + end if; + end if; + end Check_Obsolescent; + ------------------------------------------ -- Check_Potentially_Blocking_Operation -- ------------------------------------------ @@ -955,11 +1003,10 @@ package body Sem_Util is null; end if; - elsif (Is_Package (B_Scope) - and then Nkind ( - Parent (Declaration_Node (First_Subtype (T)))) - /= N_Package_Body) - + elsif (Is_Package_Or_Generic_Package (B_Scope) + and then + Nkind (Parent (Declaration_Node (First_Subtype (T)))) /= + N_Package_Body) or else Is_Derived_Type (B_Type) then -- The primitive operations appear after the base type, except @@ -1618,6 +1665,26 @@ package body Sem_Util is E : constant Entity_Id := Current_Entity_In_Scope (Def_Id); S : constant Entity_Id := Current_Scope; + function Is_Private_Component_Renaming (N : Node_Id) return Boolean; + -- Recognize a renaming declaration that is introduced for private + -- components of a protected type. We treat these as weak declarations + -- so that they are overridden by entities with the same name that + -- come from source, such as formals or local variables of a given + -- protected declaration. + + ----------------------------------- + -- Is_Private_Component_Renaming -- + ----------------------------------- + + function Is_Private_Component_Renaming (N : Node_Id) return Boolean is + begin + return not Comes_From_Source (N) + and then not Comes_From_Source (Current_Scope) + and then Nkind (N) = N_Object_Renaming_Declaration; + end Is_Private_Component_Renaming; + + -- Start of processing for Enter_Name + begin Generate_Definition (Def_Id); @@ -1742,6 +1809,9 @@ package body Sem_Util is then return; + elsif Is_Private_Component_Renaming (Parent (Def_Id)) then + return; + -- In the body or private part of an instance, a type extension -- may introduce a component with the same name as that of an -- actual. The legality rule is not enforced, but the semantics @@ -3181,7 +3251,7 @@ package body Sem_Util is function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is begin return - Is_Package (Scope_Id) + Is_Package_Or_Generic_Package (Scope_Id) and then In_Open_Scopes (Scope_Id) and then not In_Package_Body (Scope_Id) and then not In_Private_Part (Scope_Id); @@ -3450,26 +3520,30 @@ package body Sem_Util is function Is_Controlling_Limited_Procedure (Proc_Nam : Entity_Id) return Boolean is - Param_Typ : Entity_Id; + Param_Typ : Entity_Id := Empty; begin - -- Proc_Nam was found to be a primitive operation of a limited interface - - if Ekind (Proc_Nam) = E_Procedure then - Param_Typ := Etype (Parameter_Type (First (Parameter_Specifications ( - Parent (Proc_Nam))))); - return - Is_Interface (Param_Typ) - and then Is_Limited_Record (Param_Typ); + if Ekind (Proc_Nam) = E_Procedure + and then Present (Parameter_Specifications (Parent (Proc_Nam))) + then + Param_Typ := Etype (Parameter_Type (First ( + Parameter_Specifications (Parent (Proc_Nam))))); -- In this case where an Itype was created, the procedure call has been -- rewritten. elsif Present (Associated_Node_For_Itype (Proc_Nam)) and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam))) + and then + Present (Parameter_Associations + (Associated_Node_For_Itype (Proc_Nam))) then - Param_Typ := Etype (First (Parameter_Associations ( - Associated_Node_For_Itype (Proc_Nam)))); + Param_Typ := + Etype (First (Parameter_Associations + (Associated_Node_For_Itype (Proc_Nam)))); + end if; + + if Present (Param_Typ) then return Is_Interface (Param_Typ) and then Is_Limited_Record (Param_Typ); @@ -3500,7 +3574,6 @@ package body Sem_Util is function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is Comp_Decl : constant Node_Id := Parent (Comp); Comp_List : constant Node_Id := Parent (Comp_Decl); - begin return Nkind (Parent (Comp_List)) = N_Variant; end Is_Declared_Within_Variant; @@ -3717,7 +3790,6 @@ package body Sem_Util is S : constant Ureal := Small_Value (T); M : Urealp.Save_Mark; R : Boolean; - begin M := Urealp.Mark; R := (U = UR_Trunc (U / S) * S); @@ -4033,14 +4105,12 @@ package body Sem_Util is declare Ent : constant Entity_Id := Entity (Expr); Sub : constant Entity_Id := Enclosing_Subprogram (Ent); - begin if Ekind (Ent) /= E_Variable and then Ekind (Ent) /= E_In_Out_Parameter then return False; - else return Present (Sub) and then Sub = Current_Subprogram; end if; @@ -4181,10 +4251,10 @@ package body Sem_Util is return True; -- Unchecked conversions are allowed only if they come from the - -- generated code, which sometimes uses unchecked conversions for - -- out parameters in cases where code generation is unaffected. - -- We tell source unchecked conversions by seeing if they are - -- rewrites of an original UC function call, or of an explicit + -- generated code, which sometimes uses unchecked conversions for out + -- parameters in cases where code generation is unaffected. We tell + -- source unchecked conversions by seeing if they are rewrites of an + -- original Unchecked_Conversion function call, or of an explicit -- conversion of a function call. elsif Nkind (AV) = N_Unchecked_Type_Conversion then @@ -4346,7 +4416,6 @@ package body Sem_Util is elsif Is_Private_Type (Typ) then declare U : constant Entity_Id := Underlying_Type (Typ); - begin if No (U) then return True; @@ -4446,6 +4515,7 @@ package body Sem_Util is if Nkind (The_Unit) /= N_Package_Declaration then return False; end if; + return Is_Remote_Call_Interface (Defining_Entity (The_Unit)); end Is_RCI_Pkg_Decl_Cunit; @@ -6451,20 +6521,37 @@ package body Sem_Util is S : constant Entity_Id := Current_Scope; begin - if S = Standard_Standard - or else (Is_Public (S) - and then (Ekind (S) = E_Package - or else Is_Record_Type (S) - or else Ekind (S) = E_Void)) + -- Everything in the scope of Standard is public + + if S = Standard_Standard then + Set_Is_Public (Id); + + -- Entity is definitely not public if enclosing scope is not public + + elsif not Is_Public (S) then + return; + + -- An object declaration that occurs in a handled sequence of statements + -- is the declaration for a temporary object generated by the expander. + -- It never needs to be made public and furthermore, making it public + -- can cause back end problems if it is of variable size. + + elsif Nkind (Parent (Id)) = N_Object_Declaration + and then + Nkind (Parent (Parent (Id))) = N_Handled_Sequence_Of_Statements then + return; + + -- Entities in public packages or records are public + + elsif Ekind (S) = E_Package or Is_Record_Type (S) then Set_Is_Public (Id); -- The bounds of an entry family declaration can generate object -- declarations that are visible to the back-end, e.g. in the -- the declaration of a composite type that contains tasks. - elsif Is_Public (S) - and then Is_Concurrent_Type (S) + elsif Is_Concurrent_Type (S) and then not Has_Completion (S) and then Nkind (Parent (Id)) = N_Object_Declaration then @@ -6959,7 +7046,7 @@ package body Sem_Util is end if; if Is_Entity_Name (Expr) - and then Is_Package (Entity (Expr)) + and then Is_Package_Or_Generic_Package (Entity (Expr)) then Error_Msg_N ("found package name!", Expr); diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 27f2abd9708..64dd828a050 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -108,6 +108,12 @@ package Sem_Util is -- place error message on node N. Used in object declarations, type -- conversions, qualified expressions. + procedure Check_Obsolescent (Nam : Entity_Id; N : Node_Id); + -- Nam is either a subprogram or a (generic) package entity. This procedure + -- checks if the Is_Obsolescent flag is set and if so, outputs appropriate + -- diagnostics (it also checks the appropriate restriction). N is the node + -- to which error messages are attached. + procedure Check_Potentially_Blocking_Operation (N : Node_Id); -- N is one of the statement forms that is a potentially blocking -- operation. If it appears within a protected action, emit warning.