OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

sem_util.ads, [...]: Change name Is_Package to Is_Package_Or_Generic_Package. 

2005-11-14  Robert Dewar  <dewar@adacore.com>
	    Thomas Quinot  <quinot@adacore.com>
	    Hristian Kirtchev  <kirtchev@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* 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
This commit is contained in:
Robert Dewar 2005-11-15 15:04:10 +01:00 committed by Arnaud Charlet
parent 861d669e3d
commit 21024a3946
2 changed files with 127 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

155
gcc/ada/sem_util.adb
View File

@ -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);

6
gcc/ada/sem_util.ads
View File

@ -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.