Skip to content

R
riscv-gcc-1
Commit 9e87a68d by Ed Schonberg Committed by Arnaud Charlet
Options

sem_util.ads, [...] (Object_Access_Level): If the object is a dereference of a… 

sem_util.ads, [...] (Object_Access_Level): If the object is a dereference of a local object R created as a reference to...

2007-04-06  Ed Schonberg  <schonberg@adacore.com>
	    Javier Miranda  <miranda@adacore.com>

	* sem_util.ads, sem_util.adb (Object_Access_Level): If the object is a
	dereference of a local object R created as a reference to another
	object O, use the access level of O.
	(Matches_Prefixed_View_Profile): Use common predicate Conforming_Types,
	rather than local Same_Formal_Type, to check whether protected operation
	overrides an inherited one.
	(Same_Formal_Type): New predicate, used when matching signatures of
	overriding synchronized operations, to handle the case when a formal
	has a type that is a generic actual.
	(Is_Aliased_View): Replace check on E_Task_Type and E_Protected_Type by
	predicate Is_Concurrent_Type. This ensures supportin case of subtypes.
	(Needs_One_Actual): New predicate, for Ada 2005 use, to resolve
	syntactic ambiguities involving indexing of function calls that return
	arrays.
	(Abstract_Interface_List): New subprogram that returns the list of
	abstract interfaces associated with a concurrent type or a
	concurrent record type.
	(Interface_Present_In_Parent): New subprogram used to check if a
	given type or some of its parents implement a given interface.
	(Collect_Abstract_Interfaces): Add support for concurrent types
	with interface types.
	(Has_Abstract_Interfaces): Add support for concurrent types with
	interface types.
	(Is_Parent): New subprogram that determines whether E1 is a parent
	of E2. For a concurrent type its parent is the first element of its
	list of interface types; for other types this function provides the
	same result than Is_Ancestor.
	(Enclosing_Subprogram): Add test for N_Extended_Return_Statement.
	(Collect_Synchronized_Interfaces): Removed because the subprogram
	Collect_Abstract_Interfaces provides this functionality.
	(Collect_Abstract_Interfaces): Minor update to give support to
	concurrent types and thus avoid undesired code duplication.
	(Get_Subprogram_Entity): Handle entry calls.
	(May_Be_Lvalue): Include actuals that appear as in-out parameters in
	entry calls.
	(Enter_Name): Do not give -gnatwh hiding warning for record component
	entities, they never result in hiding.

From-SVN: r123599
parent 3aba5ed5
Showing with 287 additions and 161 deletions
gcc/ada/sem_util.adb
......@@ -45,6 +45,7 @@ with Rtsfind; use Rtsfind;
with Scans; use Scans;
with Scn; use Scn;
with Sem; use Sem;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
......@@ -84,6 +85,58 @@ package body Sem_Util is
-- T is a derived tagged type. Check whether the type extension is null.
-- If the parent type is fully initialized, T can be treated as such.
------------------------------
-- Abstract_Interface_List --
------------------------------
function Abstract_Interface_List (Typ : Entity_Id) return List_Id is
Nod : Node_Id;
begin
if Is_Concurrent_Type (Typ) then
Nod := Parent (Typ);
elsif Ekind (Typ) = E_Record_Type_With_Private then
if Nkind (Parent (Typ)) = N_Full_Type_Declaration then
Nod := Type_Definition (Parent (Typ));
elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then
if Present (Full_View (Typ)) then
Nod := Type_Definition (Parent (Full_View (Typ)));
-- If the full-view is not available we cannot do anything
-- else here (the source has errors)
else
return Empty_List;
end if;
-- The support for generic formals with interfaces is still
-- missing???
elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
return Empty_List;
else
pragma Assert
(Nkind (Parent (Typ)) = N_Private_Extension_Declaration);
Nod := Parent (Typ);
end if;
elsif Ekind (Typ) = E_Record_Subtype then
Nod := Type_Definition (Parent (Etype (Typ)));
else pragma Assert ((Ekind (Typ)) = E_Record_Type);
if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
Nod := Formal_Type_Definition (Parent (Typ));
else
Nod := Type_Definition (Parent (Typ));
end if;
end if;
return Interface_List (Nod);
end Abstract_Interface_List;
--------------------------------
-- Add_Access_Type_To_Process --
--------------------------------
......@@ -971,6 +1024,13 @@ package body Sem_Util is
-- Subsidiary subprogram used to traverse the whole list
-- of directly and indirectly implemented interfaces
function Interface_Present_In_Parent
(Typ : Entity_Id;
Iface : Entity_Id) return Boolean;
-- Typ must be a tagged record type/subtype and Iface must be an
-- abstract interface type. This function is used to check if Typ
-- or some parent of Typ implements Iface.
-------------------
-- Add_Interface --
-------------------
......@@ -994,54 +1054,31 @@ package body Sem_Util is
-------------
procedure Collect (Typ : Entity_Id) is
Ancestor : Entity_Id;
Id : Node_Id;
Iface : Entity_Id;
Nod : Node_Id;
Iface_List : constant List_Id := Abstract_Interface_List (Typ);
Ancestor : Entity_Id;
Id : Node_Id;
Iface : Entity_Id;
begin
if Ekind (Typ) = E_Record_Type_With_Private then
if Nkind (Parent (Typ)) = N_Full_Type_Declaration then
Nod := Type_Definition (Parent (Typ));
-- Include the ancestor if we are generating the whole list of
-- abstract interfaces.
elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then
if Present (Full_View (Typ)) then
Nod := Type_Definition (Parent (Full_View (Typ)));
-- In concurrent types the ancestor interface (if any) is the
-- first element of the list of interface types.
-- If the full-view is not available we cannot do anything
-- else here (the source has errors)
if Is_Concurrent_Type (Typ)
or else Is_Concurrent_Record_Type (Typ)
then
if Is_Non_Empty_List (Iface_List) then
Ancestor := Etype (First (Iface_List));
Collect (Ancestor);
else
return;
if not Exclude_Parent_Interfaces then
Add_Interface (Ancestor);
end if;
-- The support for generic formals with interfaces is still
-- missing???
elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
return;
else
pragma Assert
(Nkind (Parent (Typ)) = N_Private_Extension_Declaration);
Nod := Parent (Typ);
end if;
elsif Ekind (Typ) = E_Record_Subtype then
Nod := Type_Definition (Parent (Etype (Typ)));
else pragma Assert ((Ekind (Typ)) = E_Record_Type);
if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
Nod := Formal_Type_Definition (Parent (Typ));
else
Nod := Type_Definition (Parent (Typ));
end if;
end if;
-- Include the ancestor if we are generating the whole list of
-- abstract interfaces.
if Etype (Typ) /= Typ
elsif Etype (Typ) /= Typ
-- Protect the frontend against wrong sources. For example:
......@@ -1068,8 +1105,19 @@ package body Sem_Util is
-- Traverse the graph of ancestor interfaces
if Is_Non_Empty_List (Interface_List (Nod)) then
Id := First (Interface_List (Nod));
if Is_Non_Empty_List (Iface_List) then
Id := First (Iface_List);
-- In concurrent types the ancestor interface (if any) is the
-- first element of the list of interface types and we have
-- already processed them while climbing to the root type.
if Is_Concurrent_Type (Typ)
or else Is_Concurrent_Record_Type (Typ)
then
Next (Id);
end if;
while Present (Id) loop
Iface := Etype (Id);
......@@ -1080,7 +1128,7 @@ package body Sem_Util is
if Is_Interface (Iface) then
if Exclude_Parent_Interfaces
and then Interface_Present_In_Ancestor (T, Iface)
and then Interface_Present_In_Parent (T, Iface)
then
null;
else
......@@ -1094,10 +1142,37 @@ package body Sem_Util is
end if;
end Collect;
---------------------------------
-- Interface_Present_In_Parent --
---------------------------------
function Interface_Present_In_Parent
(Typ : Entity_Id;
Iface : Entity_Id) return Boolean
is
Aux : Entity_Id := Typ;
Iface_List : List_Id;
begin
if Is_Concurrent_Type (Typ)
or else Is_Concurrent_Record_Type (Typ)
then
Iface_List := Abstract_Interface_List (Typ);
if Is_Non_Empty_List (Iface_List) then
Aux := Etype (First (Iface_List));
else
return False;
end if;
end if;
return Interface_Present_In_Ancestor (Aux, Iface);
end Interface_Present_In_Parent;
-- Start of processing for Collect_Abstract_Interfaces
begin
pragma Assert (Is_Tagged_Type (T));
pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T));
Ifaces_List := New_Elmt_List;
Collect (T);
end Collect_Abstract_Interfaces;
......@@ -1236,92 +1311,6 @@ package body Sem_Util is
return Op_List;
end Collect_Primitive_Operations;
-------------------------------------
-- Collect_Synchronized_Interfaces --
-------------------------------------
procedure Collect_Synchronized_Interfaces
(Typ : Entity_Id;
Ifaces_List : out Elist_Id)
is
Iface : Entity_Id;
procedure Collect (Typ : Entity_Id);
-- Gather any parent or progenitor interfaces of type Typ
-------------
-- Collect --
-------------
procedure Collect (Typ : Entity_Id) is
Iface_Elmt : Elmt_Id;
procedure Add (Iface : Entity_Id);
-- Add a single interface to list Ifaces if the interface is
-- not already in the list.
---------
-- Add --
---------
procedure Add (Iface : Entity_Id) is
Iface_Elmt : Elmt_Id;
begin
Iface_Elmt := First_Elmt (Ifaces_List);
while Present (Iface_Elmt)
and then Node (Iface_Elmt) /= Iface
loop
Next_Elmt (Iface_Elmt);
end loop;
if No (Iface_Elmt) then
Append_Elmt (Iface, Ifaces_List);
end if;
end Add;
-- Start of processing for Collect
begin
if Is_Interface (Typ) then
-- Potential parent interface
if Etype (Typ) /= Typ then
Collect (Etype (Typ));
end if;
-- Progenitors
if Present (Abstract_Interfaces (Typ)) then
Iface_Elmt := First_Elmt (Abstract_Interfaces (Typ));
while Present (Iface_Elmt) loop
Collect (Node (Iface_Elmt));
Next_Elmt (Iface_Elmt);
end loop;
end if;
Add (Typ);
end if;
end Collect;
-- Start of processing for Collect_Synchronized_Interfaces
begin
pragma Assert (Is_Concurrent_Type (Typ));
Ifaces_List := New_Elmt_List;
if Present (Interface_List (Parent (Typ))) then
Iface := First (Interface_List (Parent (Typ)));
while Present (Iface) loop
Collect (Etype (Iface));
Next (Iface);
end loop;
end if;
end Collect_Synchronized_Interfaces;
-----------------------------------
-- Compile_Time_Constraint_Error --
-----------------------------------
......@@ -1945,7 +1934,9 @@ package body Sem_Util is
elsif Ekind (Dynamic_Scope) = E_Subprogram_Body then
return Corresponding_Spec (Parent (Parent (Dynamic_Scope)));
elsif Ekind (Dynamic_Scope) = E_Block then
elsif Ekind (Dynamic_Scope) = E_Block
or else Ekind (Dynamic_Scope) = E_Return_Statement
then
return Enclosing_Subprogram (Dynamic_Scope);
elsif Ekind (Dynamic_Scope) = E_Task_Type then
......@@ -2286,6 +2277,17 @@ package body Sem_Util is
if Warn_On_Hiding and then Present (C)
-- Don't warn for record components since they always have a well
-- defined scope which does not confuse other uses. Note that in
-- some cases, Ekind has not been set yet.
and then Ekind (C) /= E_Component
and then Ekind (C) /= E_Discriminant
and then Nkind (Parent (C)) /= N_Component_Declaration
and then Ekind (Def_Id) /= E_Component
and then Ekind (Def_Id) /= E_Discriminant
and then Nkind (Parent (Def_Id)) /= N_Component_Declaration
-- Don't warn for one character variables. It is too common to use
-- such variables as locals and will just cause too many false hits.
......@@ -3062,6 +3064,17 @@ package body Sem_Util is
begin
if Nkind (Nod) = N_Accept_Statement then
Nam := Entry_Direct_Name (Nod);
-- For an entry call, the prefix of the call is a selected component.
-- Need additional code for internal calls ???
elsif Nkind (Nod) = N_Entry_Call_Statement then
if Nkind (Name (Nod)) = N_Selected_Component then
Nam := Entity (Selector_Name (Name (Nod)));
else
Nam := Empty;
end if;
else
Nam := Name (Nod);
end if;
......@@ -3167,6 +3180,14 @@ package body Sem_Util is
pragma Assert (Is_Record_Type (Tagged_Type)
and then Is_Tagged_Type (Tagged_Type));
-- Handle concurrent record types
if Is_Concurrent_Record_Type (Tagged_Type)
and then Is_Non_Empty_List (Abstract_Interface_List (Tagged_Type))
then
return True;
end if;
-- Handle private types
if Present (Full_View (Tagged_Type)) then
......@@ -3236,17 +3257,13 @@ package body Sem_Util is
Comp : Entity_Id;
begin
Comp := First_Entity (Typ);
Comp := First_Component_Or_Discriminant (Typ);
while Present (Comp) loop
if (Ekind (Comp) = E_Component
or else
Ekind (Comp) = E_Discriminant)
and then Has_Access_Values (Etype (Comp))
then
if Has_Access_Values (Etype (Comp)) then
return True;
end if;
Next_Entity (Comp);
Next_Component_Or_Discriminant (Comp);
end loop;
end;
......@@ -3776,8 +3793,8 @@ package body Sem_Util is
-- We are interested only in components and discriminants
if Ekind (Ent) = E_Component
or else
Ekind (Ent) = E_Discriminant
or else
Ekind (Ent) = E_Discriminant
then
-- Get default expression if any. If there is no declaration
-- node, it means we have an internal entity. The parent and
......@@ -4382,9 +4399,8 @@ package body Sem_Util is
or else Ekind (E) = E_Generic_In_Parameter)
and then Is_Tagged_Type (Etype (E)))
or else ((Ekind (E) = E_Task_Type
or else Ekind (E) = E_Protected_Type)
and then In_Open_Scopes (E))
or else (Is_Concurrent_Type (E)
and then In_Open_Scopes (E))
-- Current instance of type, either directly or as rewritten
-- reference to the current object.
......@@ -4394,6 +4410,7 @@ package body Sem_Util is
and then Is_Type (Entity (Original_Node (Obj))))
or else (Is_Type (E) and then E = Current_Scope)
or else (Is_Incomplete_Or_Private_Type (E)
and then Full_View (E) = Current_Scope);
......@@ -5259,6 +5276,33 @@ package body Sem_Util is
end if;
end Is_OK_Variable_For_Out_Formal;
---------------
-- Is_Parent --
---------------
function Is_Parent
(E1 : Entity_Id;
E2 : Entity_Id) return Boolean
is
Iface_List : List_Id;
T : Entity_Id := E2;
begin
if Is_Concurrent_Type (T)
or else Is_Concurrent_Record_Type (T)
then
Iface_List := Abstract_Interface_List (E2);
if Is_Empty_List (Iface_List) then
return False;
end if;
T := Etype (First (Iface_List));
end if;
return Is_Ancestor (E1, T);
end Is_Parent;
-----------------------------------
-- Is_Partially_Initialized_Type --
-----------------------------------
......@@ -6241,9 +6285,10 @@ package body Sem_Util is
when N_Function_Call =>
return False;
-- Positional parameter for procedure or accept call
-- Positional parameter for procedure, entry, or accept call
when N_Procedure_Call_Statement |
N_Entry_Call_Statement |
N_Accept_Statement
=>
declare
......@@ -6340,6 +6385,33 @@ package body Sem_Util is
end case;
end May_Be_Lvalue;
----------------------
-- Needs_One_Actual --
----------------------
function Needs_One_Actual (E : Entity_Id) return Boolean is
Formal : Entity_Id;
begin
if Ada_Version >= Ada_05
and then Present (First_Formal (E))
then
Formal := Next_Formal (First_Formal (E));
while Present (Formal) loop
if No (Default_Value (Formal)) then
return False;
end if;
Next_Formal (Formal);
end loop;
return True;
else
return False;
end if;
end Needs_One_Actual;
-------------------------
-- New_External_Entity --
-------------------------
......@@ -6853,6 +6925,34 @@ package body Sem_Util is
-- is not always one is immaterial (invariant: if level(E2) is
-- deeper than level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
function Reference_To (Obj : Node_Id) return Node_Id;
-- An explicit dereference is created when removing side-effects
-- from expressions for constraint checking purposes. In this case
-- a local access type is created for it. The correct access level
-- is that of the original source node. We detect this case by
-- noting that the prefix of the dereference is created by an object
-- declaration whose initial expression is a reference.
------------------
-- Reference_To --
------------------
function Reference_To (Obj : Node_Id) return Node_Id is
Pref : constant Node_Id := Prefix (Obj);
begin
if Is_Entity_Name (Pref)
and then Nkind (Parent (Entity (Pref))) = N_Object_Declaration
and then Present (Expression (Parent (Entity (Pref))))
and then Nkind (Expression (Parent (Entity (Pref)))) = N_Reference
then
return (Prefix (Expression (Parent (Entity (Pref)))));
else
return Empty;
end if;
end Reference_To;
-- Start of processing for Object_Access_Level
begin
if Is_Entity_Name (Obj) then
E := Entity (Obj);
......@@ -6912,6 +7012,18 @@ package body Sem_Util is
Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant
then
return Object_Access_Level (Prefix (Obj));
elsif not (Comes_From_Source (Obj)) then
declare
Ref : constant Node_Id := Reference_To (Obj);
begin
if Present (Ref) then
return Object_Access_Level (Ref);
else
return Type_Access_Level (Etype (Prefix (Obj)));
end if;
end;
else
return Type_Access_Level (Etype (Prefix (Obj)));
end if;
......@@ -7044,8 +7156,10 @@ package body Sem_Util is
if Ekind (Defining_Identifier (Subp_Param)) /=
Ekind (Defining_Identifier (Over_Param))
or else
Etype (Parameter_Type (Subp_Param)) /=
Etype (Parameter_Type (Over_Param))
not Conforming_Types
(Etype (Parameter_Type (Subp_Param)),
Etype (Parameter_Type (Over_Param)),
Subtype_Conformant)
then
return False;
end if;
......@@ -7083,7 +7197,7 @@ package body Sem_Util is
if Ekind (Def_Id) = E_Entry
and then Ekind (Candidate) = E_Procedure
and then Nkind (Parent (Candidate)) = N_Procedure_Specification
and then (Is_Abstract (Candidate)
and then (Is_Abstract_Subprogram (Candidate)
or else Null_Present (Parent (Candidate)))
then
while Present (Alias (Candidate)) loop
......@@ -7102,7 +7216,7 @@ package body Sem_Util is
elsif Ekind (Def_Id) = E_Procedure
and then Ekind (Candidate) = E_Procedure
and then Nkind (Parent (Candidate)) = N_Procedure_Specification
and then (Is_Abstract (Candidate)
and then (Is_Abstract_Subprogram (Candidate)
or else Null_Present (Parent (Candidate)))
and then Matches_Prefixed_View_Profile
(Parameter_Specifications (Parent (Def_Id)),
......@@ -7115,7 +7229,7 @@ package body Sem_Util is
elsif Ekind (Def_Id) = E_Function
and then Ekind (Candidate) = E_Function
and then Nkind (Parent (Candidate)) = N_Function_Specification
and then Is_Abstract (Candidate)
and then Is_Abstract_Subprogram (Candidate)
and then Matches_Prefixed_View_Profile
(Parameter_Specifications (Parent (Def_Id)),
Parameter_Specifications (Parent (Candidate)))
......@@ -7995,6 +8109,7 @@ package body Sem_Util is
then
Set_Is_Unsigned_Type (T1, Is_Unsigned_Type (T2));
end if;
Set_Alignment (T1, Alignment (T2));
end Set_Size_Info;
......@@ -8461,9 +8576,9 @@ package body Sem_Util is
else
if From_With_Type (Found_Type) then
Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type);
Error_Msg_NE
("\possibly missing with_clause on&", Expr,
Scope (Found_Type));
Error_Msg_Qual_Level := 99;
Error_Msg_NE ("\\missing `WITH &;", Expr, Scope (Found_Type));
Error_Msg_Qual_Level := 0;
else
Error_Msg_NE ("found}!", Expr, Found_Type);
end if;
......
gcc/ada/sem_util.ads
......@@ -33,6 +33,10 @@ with Urealp; use Urealp;
package Sem_Util is
function Abstract_Interface_List (Typ : Entity_Id) return List_Id;
-- Given a type that implements interfaces look for its associated
-- definition node and return its list of interfaces.
procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id);
-- Add A to the list of access types to process when expanding the
-- freeze node of E.
......@@ -140,12 +144,6 @@ package Sem_Util is
-- one subsidiary subtype of the type. These subprograms can only
-- appear after the type itself.
procedure Collect_Synchronized_Interfaces
(Typ : Entity_Id;
Ifaces_List : out Elist_Id);
-- Similar to Collect_Abstract_Interfaces, but tailored to task and
-- protected types.
function Compile_Time_Constraint_Error
(N : Node_Id;
Msg : String;
......@@ -598,12 +596,20 @@ package Sem_Util is
-- is a variable (in the Is_Variable sense) with a non-tagged type
-- target are considered view conversions and hence variables.
function Is_Parent
(E1 : Entity_Id;
E2 : Entity_Id) return Boolean;
-- Determine whether E1 is a parent of E2. For a concurrent type, the
-- parent is the first element of its list of interface types; for other
-- types, this function provides the same result as Is_Ancestor.
function Is_Partially_Initialized_Type (Typ : Entity_Id) return Boolean;
-- Typ is a type entity. This function returns true if this type is
-- partly initialized, meaning that an object of the type is at least
-- partly initialized (in particular in the record case, that at least
-- one field has an initialization expression). Note that initialization
-- resulting from the use of pragma Normalized_Scalars does not count.
-- one component has an initialization expression). Note that
-- initialization resulting from the use of pragma Normalized_Scalars does
-- not count.
function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean;
-- Determines if type T is a potentially persistent type. A potentially
......@@ -618,7 +624,7 @@ package Sem_Util is
-- body of a remote call interface package.
function Is_Remote_Access_To_Class_Wide_Type (E : Entity_Id) return Boolean;
-- Return True if E is a remote access-to-class-wide-limited_private type
-- Return True if E is a remote access-to-class-wide type
function Is_Remote_Access_To_Subprogram_Type (E : Entity_Id) return Boolean;
-- Return True if E is a remote access to subprogram type
......@@ -710,6 +716,11 @@ package Sem_Util is
-- to guarantee this in all cases. Note that it is more possible to give
-- correct answer if the tree is fully analyzed.
function Needs_One_Actual (E : Entity_Id) return Boolean;
-- Returns True if a function has defaults for all but its first
-- formal. Used in Ada 2005 mode to solve the syntactic ambiguity that
-- results from an indexing of a function call written in prefix form.
function New_External_Entity
(Kind : Entity_Kind;
Scope_Id : Entity_Id;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment