Skip to content

R
riscv-gcc-1
Commit dc06abec by Robert Dewar Committed by Arnaud Charlet
Options

sem_ch11.adb: Improved warnings for unused variables 

2007-08-14  Robert Dewar  <dewar@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* sem_ch11.adb: Improved warnings for unused variables

	* sem_ch3.ads, sem_ch3.adb (Build_Derived_Record_Type): If the ancestor
	is a synchronized interface, the derived type is limited.
	(Analyze_Object_Declaration): Mark the potential coextensions in the
	definition and expression of an object declaration node.
	(Build_Derived_Type): For the completion of a private type declaration
	with a derived type declaration, chain the parent type's representation
	items to the last representation item of the derived type (not the
	first one) if they are not present already.
	(Analyze_Object_Declaration, Constant_Redeclaration): Allow incomplete
	object declaration of forward references to tags.
	(Access_Subprogram_Declaration): In Ada2005, anonymous access to
	subprogram types can appear as access discriminants of synchronized
	types.
	(OK_For_Limited_Init_In_05): The initialization is legal is it is a call
	given in prefixed form as a selected component.
	(Process_Discriminants): If not all discriminants have defaults, place
	error message on a default that is present.
	(Analyze_Private_Extension_Declaration): Diagnose properly an attempt to
	extend a synchronized tagged type.
	Improved warnings for unused variables
	(Is_Visible_Component): Fix a visibility hole on a component inherited
	by a private extension when parent is itself declared as a private
	extension, and the derivation is in a child unit.
	(Find_Hidden_Interface): Move spec from the package body.

From-SVN: r127426
parent 442ade9d
Showing with 254 additions and 182 deletions
gcc/ada/sem_ch11.adb
......@@ -225,9 +225,11 @@ package body Sem_Ch11 is
Generate_Definition (Choice);
-- Set source assigned flag, since in effect this field is
-- always assigned an initial value by the exception.
-- Indicate that choice has an initial value, since in effect
-- this field is assigned an initial value by the exception.
-- We also consider that it is modified in the source.
Set_Has_Initial_Value (Choice, True);
Set_Never_Set_In_Source (Choice, False);
end if;
......@@ -269,7 +271,7 @@ package body Sem_Ch11 is
if Warn_On_Obsolescent_Feature then
Error_Msg_N
("Numeric_Error is an " &
"obsolescent feature ('R'M 'J.6(1))?", Id);
"obsolescent feature (RM J.6(1))?", Id);
Error_Msg_N
("\use Constraint_Error instead?", Id);
end if;
......@@ -306,7 +308,7 @@ package body Sem_Ch11 is
"generic formal package", Id, Ent);
Error_Msg_N
("\and therefore cannot appear in " &
"handler ('R'M 11.2(8))", Id);
"handler (RM 11.2(8))", Id);
exit;
-- If the exception is declared in an inner
......@@ -462,7 +464,7 @@ package body Sem_Ch11 is
P);
Error_Msg_N
("\?RAISE statement may result in abnormal return" &
" ('R'M 6.4.1(17))", P);
" (RM 6.4.1(17))", P);
end if;
end if;
end;
......
gcc/ada/sem_ch3.adb
......@@ -208,8 +208,8 @@ package body Sem_Ch3 is
--
-- the call completes Def_Id to be the appropriate E_*_Subtype.
--
-- The Elist is the list of discriminant constraints if any (it is set to
-- No_Elist if T is not a discriminated type, and to an empty list if
-- The Elist is the list of discriminant constraints if any (it is set
-- to No_Elist if T is not a discriminated type, and to an empty list if
-- T has discriminants but there are no discriminant constraints). The
-- Related_Nod is the same as Decl_Node in Create_Constrained_Components.
-- The For_Access says whether or not this subtype is really constraining
......@@ -308,6 +308,11 @@ package body Sem_Ch3 is
-- Id is the entity for the redeclaration, N is the N_Object_Declaration,
-- node. The caller has not yet set any attributes of this entity.
function Contain_Interface
(Iface : Entity_Id;
Ifaces : Elist_Id) return Boolean;
-- Ada 2005: Determine whether Iface is present in the list Ifaces
procedure Convert_Scalar_Bounds
(N : Node_Id;
Parent_Type : Entity_Id;
......@@ -935,6 +940,8 @@ package body Sem_Ch3 is
and then Nkind (D_Ityp) /= N_Object_Declaration
and then Nkind (D_Ityp) /= N_Object_Renaming_Declaration
and then Nkind (D_Ityp) /= N_Formal_Type_Declaration
and then Nkind (D_Ityp) /= N_Task_Type_Declaration
and then Nkind (D_Ityp) /= N_Protected_Type_Declaration
loop
D_Ityp := Parent (D_Ityp);
pragma Assert (D_Ityp /= Empty);
......@@ -1386,7 +1393,7 @@ package body Sem_Ch3 is
function Contains_POC (Constr : Node_Id) return Boolean is
begin
-- Prevent cascaded errors.
-- Prevent cascaded errors
if Error_Posted (Constr) then
return False;
......@@ -1553,8 +1560,7 @@ package body Sem_Ch3 is
E_Class_Wide_Type
then
Error_Msg_N
("access to specific tagged type required ('R'M 3.9.2(9))",
E);
("access to specific tagged type required (RM 3.9.2(9))", E);
end if;
-- (Ada 2005: AI-230): Accessibility check for anonymous
......@@ -1563,7 +1569,7 @@ package body Sem_Ch3 is
if Type_Access_Level (Etype (E)) > Type_Access_Level (T) then
Error_Msg_N
("expression has deeper access level than component " &
"('R'M 3.10.2 (12.2))", E);
"(RM 3.10.2 (12.2))", E);
end if;
-- The initialization expression is a reference to an access
......@@ -2211,6 +2217,8 @@ package body Sem_Ch3 is
Generate_Definition (Id);
Enter_Name (Id);
Mark_Coextensions (N, Object_Definition (N));
T := Find_Type_Of_Object (Object_Definition (N), N);
if Nkind (Object_Definition (N)) = N_Access_Definition
......@@ -2265,9 +2273,19 @@ package body Sem_Ch3 is
if Constant_Present (N)
and then No (E)
then
if not Is_Package_Or_Generic_Package (Current_Scope) then
-- We exclude forward references to tags
if Is_Imported (Defining_Identifier (N))
and then
(T = RTE (RE_Tag)
or else (Present (Full_View (T))
and then Full_View (T) = RTE (RE_Tag)))
then
null;
elsif not Is_Package_Or_Generic_Package (Current_Scope) then
Error_Msg_N
("invalid context for deferred constant declaration ('R'M 7.4)",
("invalid context for deferred constant declaration (RM 7.4)",
N);
Error_Msg_N
("\declaration requires an initialization expression",
......@@ -2330,7 +2348,7 @@ package body Sem_Ch3 is
-- Process initialization expression if present and not in error
if Present (E) and then E /= Error then
Mark_Static_Coextensions (E);
Mark_Coextensions (N, E);
Analyze (E);
-- In case of errors detected in the analysis of the expression,
......@@ -2370,6 +2388,18 @@ package body Sem_Ch3 is
end if;
end if;
-- Deal with setting of null flags
if Is_Access_Type (T) then
if Known_Non_Null (E) then
Set_Is_Known_Non_Null (Id, True);
elsif Known_Null (E)
and then not Can_Never_Be_Null (Id)
then
Set_Is_Known_Null (Id, True);
end if;
end if;
-- Check incorrect use of dynamically tagged expressions. Note
-- the use of Is_Tagged_Type (T) which seems redundant but is in
-- fact important to avoid spurious errors due to expanded code
......@@ -2572,11 +2602,16 @@ package body Sem_Ch3 is
Check_Restriction (No_Wide_Characters, Object_Definition (N));
end if;
-- Indicate this is not set in source. Certainly true for constants,
-- and true for variables so far (will be reset for a variable if and
-- when we encounter a modification in the source).
Set_Never_Set_In_Source (Id, True);
-- Now establish the proper kind and type of the object
if Constant_Present (N) then
Set_Ekind (Id, E_Constant);
Set_Never_Set_In_Source (Id, True);
Set_Is_True_Constant (Id, True);
else
......@@ -2595,29 +2630,23 @@ package body Sem_Ch3 is
Check_Shared_Var (Id, T, N);
end if;
-- Case of no initializing expression present. If the type is not
-- fully initialized, then we set Never_Set_In_Source, since this
-- is a case of a potentially uninitialized object. Note that we
-- do not consider access variables to be fully initialized for
-- this purpose, since it still seems dubious if someone declares
-- Note that we only do this for source declarations. If the object
-- is declared by a generated declaration, we assume that it is not
-- appropriate to generate warnings in that case.
-- Set Has_Initial_Value if initializing expression present. Note
-- that if there is no initializating expression, we leave the state
-- of this flag unchanged (usually it will be False, but notably in
-- the case of exception choice variables, it will already be true).
if No (E) then
if (Is_Access_Type (T)
or else not Is_Fully_Initialized_Type (T))
and then Comes_From_Source (N)
then
Set_Never_Set_In_Source (Id);
end if;
if Present (E) then
Set_Has_Initial_Value (Id, True);
end if;
end if;
-- Initialize alignment and size
Init_Alignment (Id);
Init_Esize (Id);
-- Deal with aliased case
if Aliased_Present (N) then
Set_Is_Aliased (Id);
......@@ -2641,8 +2670,12 @@ package body Sem_Ch3 is
end if;
end if;
-- Now we can set the type of the object
Set_Etype (Id, Act_T);
-- Deal with controlled types
if Has_Controlled_Component (Etype (Id))
or else Is_Controlled (Etype (Id))
then
......@@ -2924,6 +2957,17 @@ package body Sem_Ch3 is
then
Error_Msg_N ("premature derivation of incomplete type", Indic);
return;
elsif Is_Concurrent_Type (Parent_Type) then
Error_Msg_N
("parent type of a private extension cannot be "
& "a synchronized tagged type (RM 3.9.1 (3/1))", N);
Set_Etype (T, Any_Type);
Set_Ekind (T, E_Limited_Private_Type);
Set_Private_Dependents (T, New_Elmt_List);
Set_Error_Posted (T);
return;
end if;
-- Perhaps the parent type should be changed to the class-wide type's
......@@ -3421,7 +3465,7 @@ package body Sem_Ch3 is
(Subtype_Mark (Subtype_Indication (N)))));
begin
R_Checks :=
Range_Check
Get_Range_Checks
(Scalar_Range (Etype (First_Index (Id))),
Target_Typ,
Etype (First_Index (Id)),
......@@ -4097,7 +4141,6 @@ package body Sem_Ch3 is
declare
Indices : constant List_Id :=
New_List (New_Occurrence_Of (Any_Id, Sloc (T)));
begin
Set_Discrete_Subtype_Definitions (Def, Indices);
Set_First_Index (T, First (Indices));
......@@ -6224,7 +6267,7 @@ package body Sem_Ch3 is
then
Error_Msg_NE
("parent type of& must not be outside generic body"
& " ('R'M 3.9.1(4))",
& " (RM 3.9.1(4))",
Indic, Derived_Type);
end if;
end;
......@@ -6291,13 +6334,20 @@ package body Sem_Ch3 is
-- AI-419: Limitedness is not inherited from an interface parent, so to
-- be limited in that case the type must be explicitly declared as
-- limited.
-- limited. However, task and protected interfaces are always limited.
Set_Is_Limited_Record
(Derived_Type,
Limited_Present (Type_Def)
or else (Is_Limited_Record (Parent_Type)
and then not Is_Interface (Parent_Type)));
if Limited_Present (Type_Def) then
Set_Is_Limited_Record (Derived_Type);
elsif Is_Limited_Record (Parent_Type) then
if not Is_Interface (Parent_Type)
or else Is_Synchronized_Interface (Parent_Type)
or else Is_Protected_Interface (Parent_Type)
or else Is_Task_Interface (Parent_Type)
then
Set_Is_Limited_Record (Derived_Type);
end if;
end if;
-- STEP 2a: process discriminants of derived type if any
......@@ -6797,22 +6847,40 @@ package body Sem_Ch3 is
declare
Rep : Node_Id;
-- Used to iterate over representation items of the derived type
Last_Rep : Node_Id;
-- Last representation item of the (non-empty) representation
-- item list of the derived type.
Found : Boolean := False;
begin
Rep := First_Rep_Item (Derived_Type);
Last_Rep := Rep;
while Present (Rep) loop
if Rep = First_Rep_Item (Parent_Type) then
Found := True;
exit;
else
Rep := Next_Rep_Item (Rep);
if Present (Rep) then
Last_Rep := Rep;
end if;
end if;
end loop;
-- Here if we either encountered the parent type's first rep
-- item on the derived type's rep item list (in which case
-- Found is True, and we have nothing else to do), or if we
-- reached the last rep item of the derived type, which is
-- Last_Rep, in which case we further chain the parent type's
-- rep items to those of the derived type.
if not Found then
Set_Next_Rep_Item
(First_Rep_Item (Derived_Type), First_Rep_Item (Parent_Type));
Set_Next_Rep_Item (Last_Rep, First_Rep_Item (Parent_Type));
end if;
end;
......@@ -7353,19 +7421,6 @@ package body Sem_Ch3 is
elsif not For_Access then
Set_Cloned_Subtype (Def_Id, T);
end if;
-- Handle subtypes associated with statically allocated dispatch
-- tables.
if Static_Dispatch_Tables
and then VM_Target = No_VM
and then RTU_Loaded (Ada_Tags)
and then (T = RTE (RE_Dispatch_Table_Wrapper)
or else
T = RTE (RE_Type_Specific_Data))
then
Set_Size_Known_At_Compile_Time (Def_Id);
end if;
end if;
end Build_Discriminated_Subtype;
......@@ -7701,6 +7756,8 @@ package body Sem_Ch3 is
-- overriding in Ada2005, but wrappers need to be built for them
-- (see exp_ch3, Build_Controlling_Function_Wrappers).
-- Use elseif here and avoid above goto???
if Is_Null_Extension (T)
and then Has_Controlling_Result (Subp)
and then Ada_Version >= Ada_05
......@@ -7798,22 +7855,16 @@ package body Sem_Ch3 is
-- The controlling formal of Subp must be of mode "out",
-- "in out" or an access-to-variable to be overridden.
-- Error message below needs rewording (remember comma
-- in -gnatj mode) ???
if Ekind (First_Formal (Subp)) = E_In_Parameter then
Error_Msg_NE
("first formal of & must be of mode `OUT`, `IN OUT` " &
"or access-to-variable", T, Subp);
if Is_Protected_Type
(Corresponding_Concurrent_Type (T))
then
Error_Msg_N
("\to be overridden by protected procedure or " &
"entry (`R`M 9.4(11))", T);
else
Error_Msg_N
("\to be overridden by task entry (`R`M 9.4(11))",
T);
end if;
"entry (RM 9.4(11.9/2))", T);
-- Some other kind of overriding failure
......@@ -7896,7 +7947,7 @@ package body Sem_Ch3 is
and then Ada_Version < Ada_05
then
Error_Msg_N
("aliased component must be constrained ('R'M 3.6(11))",
("aliased component must be constrained (RM 3.6(11))",
C);
end if;
......@@ -7911,7 +7962,7 @@ package body Sem_Ch3 is
and then Ada_Version < Ada_05
then
Error_Msg_N
("aliased component type must be constrained ('R'M 3.6(11))",
("aliased component type must be constrained (RM 3.6(11))",
T);
end if;
end if;
......@@ -8705,10 +8756,19 @@ package body Sem_Ch3 is
Error_Msg_N ("ALIASED required (see declaration#)", N);
end if;
-- Allow incomplete declaration of tags (used to handle forward
-- references to tags). The check on Ada_Tags avoids cicularities
-- when rebuilding the compiler.
if RTU_Loaded (Ada_Tags)
and then T = RTE (RE_Tag)
then
null;
-- Check that placement is in private part and that the incomplete
-- declaration appeared in the visible part.
if Ekind (Current_Scope) = E_Package
elsif Ekind (Current_Scope) = E_Package
and then not In_Private_Part (Current_Scope)
then
Error_Msg_Sloc := Sloc (Prev);
......@@ -9811,7 +9871,7 @@ package body Sem_Ch3 is
if Warn_On_Obsolescent_Feature then
Error_Msg_N
("subtype digits constraint is an " &
"obsolescent feature ('R'M 'J.3(8))?", C);
"obsolescent feature (RM J.3(8))?", C);
end if;
D := Digits_Expression (C);
......@@ -10014,7 +10074,7 @@ package body Sem_Ch3 is
if Warn_On_Obsolescent_Feature then
Error_Msg_S
("subtype delta constraint is an " &
"obsolescent feature ('R'M 'J.3(7))?");
"obsolescent feature (RM J.3(7))?");
end if;
D := Delta_Expression (C);
......@@ -10063,6 +10123,31 @@ package body Sem_Ch3 is
Set_Has_Delayed_Freeze (Def_Id);
end Constrain_Ordinary_Fixed;
-----------------------
-- Contain_Interface --
-----------------------
function Contain_Interface
(Iface : Entity_Id;
Ifaces : Elist_Id) return Boolean
is
Iface_Elmt : Elmt_Id;
begin
if Present (Ifaces) then
Iface_Elmt := First_Elmt (Ifaces);
while Present (Iface_Elmt) loop
if Node (Iface_Elmt) = Iface then
return True;
end if;
Next_Elmt (Iface_Elmt);
end loop;
end if;
return False;
end Contain_Interface;
---------------------------
-- Convert_Scalar_Bounds --
---------------------------
......@@ -10501,19 +10586,17 @@ package body Sem_Ch3 is
begin
Constr := First_Elmt (Stored_Constraint (Typ));
Old_Discr := First_Stored_Discriminant (Typ);
while Present (Constr) loop
if Is_Entity_Name (Node (Constr))
and then Ekind (Entity (Node (Constr))) = E_Discriminant
then
New_Discr := Entity (Node (Constr));
if Chars (Corresponding_Discriminant (New_Discr))
/= Chars (Old_Discr)
if Chars (Corresponding_Discriminant (New_Discr)) /=
Chars (Old_Discr)
then
-- The new discriminant has been used to rename
-- a subsequent old discriminant. Introduce a shadow
-- The new discriminant has been used to rename a
-- subsequent old discriminant. Introduce a shadow
-- component for the current old discriminant.
New_C := Create_Component (Old_Discr);
......@@ -11691,8 +11774,8 @@ package body Sem_Ch3 is
if Interface_Present (Def) then
if not Is_Interface (Parent_Type) then
Error_Msg_NE ("(Ada 2005) & must be an interface",
Indic, Parent_Type);
Error_Msg_NE
("(Ada 2005) & must be an interface", Indic, Parent_Type);
else
Parent_Node := Parent (Base_Type (Parent_Type));
......@@ -11706,20 +11789,24 @@ package body Sem_Ch3 is
null;
elsif Protected_Present (Iface_Def) then
Error_Msg_N ("(Ada 2005) limited interface cannot" &
" inherit from protected interface", Indic);
Error_Msg_N
("(Ada 2005) limited interface cannot "
& "inherit from protected interface", Indic);
elsif Synchronized_Present (Iface_Def) then
Error_Msg_N ("(Ada 2005) limited interface cannot" &
" inherit from synchronized interface", Indic);
Error_Msg_N
("(Ada 2005) limited interface cannot "
& "inherit from synchronized interface", Indic);
elsif Task_Present (Iface_Def) then
Error_Msg_N ("(Ada 2005) limited interface cannot" &
" inherit from task interface", Indic);
Error_Msg_N
("(Ada 2005) limited interface cannot "
& "inherit from task interface", Indic);
else
Error_Msg_N ("(Ada 2005) limited interface cannot" &
" inherit from non-limited interface", Indic);
Error_Msg_N
("(Ada 2005) limited interface cannot "
& "inherit from non-limited interface", Indic);
end if;
-- Ada 2005 (AI-345): Non-limited interfaces can only inherit
......@@ -11734,18 +11821,18 @@ package body Sem_Ch3 is
elsif Protected_Present (Iface_Def) then
Error_Msg_N
("(Ada 2005) non-limited interface cannot " &
"inherit from protected interface", Indic);
("(Ada 2005) non-limited interface cannot "
& "inherit from protected interface", Indic);
elsif Synchronized_Present (Iface_Def) then
Error_Msg_N
("(Ada 2005) non-limited interface cannot " &
"inherit from synchronized interface", Indic);
("(Ada 2005) non-limited interface cannot "
& "inherit from synchronized interface", Indic);
elsif Task_Present (Iface_Def) then
Error_Msg_N
("(Ada 2005) non-limited interface cannot " &
"inherit from task interface", Indic);
("(Ada 2005) non-limited interface cannot "
& "inherit from task interface", Indic);
else
null;
......@@ -11757,10 +11844,11 @@ package body Sem_Ch3 is
if Is_Tagged_Type (Parent_Type)
and then Is_Concurrent_Type (Parent_Type)
and then not Is_Interface (Parent_Type)
and then not Is_Completion
then
Error_Msg_N ("parent type of a record extension cannot be " &
"a synchronized tagged type (3.9.1 (3/1)", N);
Error_Msg_N
("parent type of a record extension cannot be "
& "a synchronized tagged type (RM 3.9.1 (3/1))", N);
Set_Etype (T, Any_Type);
return;
end if;
......@@ -12257,6 +12345,36 @@ package body Sem_Ch3 is
return Expansion;
end Expand_To_Stored_Constraint;
---------------------------
-- Find_Hidden_Interface --
---------------------------
function Find_Hidden_Interface
(Src : Elist_Id;
Dest : Elist_Id) return Entity_Id
is
Iface : Entity_Id;
Iface_Elmt : Elmt_Id;
begin
if Present (Src) and then Present (Dest) then
Iface_Elmt := First_Elmt (Src);
while Present (Iface_Elmt) loop
Iface := Node (Iface_Elmt);
if Is_Interface (Iface)
and then not Contain_Interface (Iface, Dest)
then
return Iface;
end if;
Next_Elmt (Iface_Elmt);
end loop;
end if;
return Empty;
end Find_Hidden_Interface;
--------------------
-- Find_Type_Name --
--------------------
......@@ -12354,8 +12472,9 @@ package body Sem_Ch3 is
end if;
end if;
-- Ada 2005 (AI-251): Private extension declaration of a
-- task type. This case arises with tasks implementing interfaces
-- Ada 2005 (AI-251): Private extension declaration of a task
-- type or a protected type. This case arises when covering
-- interface types.
elsif Nkind (N) = N_Task_Type_Declaration
or else Nkind (N) = N_Protected_Type_Declaration
......@@ -13471,7 +13590,7 @@ package body Sem_Ch3 is
-- If the component has been declared in an ancestor which is currently
-- a private type, then it is not visible. The same applies if the
-- component's containing type is not in an open scope and the original
-- component's enclosing type is a visible full type of a private type
-- component's enclosing type is a visible full view of a private type
-- (which can occur in cases where an attempt is being made to reference
-- a component in a sibling package that is inherited from a visible
-- component of a type in an ancestor package; the component in the
......@@ -13506,6 +13625,7 @@ package body Sem_Ch3 is
else
return
Is_Child_Unit (Cunit_Entity (Current_Sem_Unit))
and then In_Open_Scopes (Scope (Original_Scope))
and then Is_Local_Type (Type_Scope);
end if;
......@@ -14003,6 +14123,7 @@ package body Sem_Ch3 is
Set_Modular_Size (System_Max_Binary_Modulus_Power);
Init_Alignment (T);
end Modular_Type_Declaration;
--------------------------
......@@ -14097,7 +14218,7 @@ package body Sem_Ch3 is
return OK_For_Limited_Init_In_05
(Expression (Original_Node (Exp)));
when N_Indexed_Component =>
when N_Indexed_Component | N_Selected_Component =>
return Nkind (Exp) = N_Function_Call;
when others =>
......@@ -14284,7 +14405,6 @@ package body Sem_Ch3 is
begin
-- A composite type other than an array type can have discriminants.
-- Discriminants of non-limited types must have a discrete type.
-- On entry, the current scope is the composite type.
-- The discriminants are initially entered into the scope of the type
......@@ -14444,7 +14564,8 @@ package body Sem_Ch3 is
or else Ekind (Current_Scope) = E_Limited_Private_Type
then
null;
else
elsif Present (Expression (Discr)) then
Error_Msg_N
("(Ada 2005) access discriminants of nonlimited types",
Expression (Discr));
......@@ -14532,18 +14653,6 @@ package body Sem_Ch3 is
-- inherently implements. Duplicate entries are not added to
-- the list Ifaces.
function Contain_Interface
(Iface : Entity_Id;
Ifaces : Elist_Id) return Boolean;
-- Ada 2005: Determine whether Iface is present in the list Ifaces
function Find_Hidden_Interface
(Src : Elist_Id;
Dest : Elist_Id) return Entity_Id;
-- Ada 2005: Determine whether the interfaces in list Src are all
-- present in the list Dest. Return the first differing interface,
-- or Empty otherwise.
------------------------------------
-- Collect_Implemented_Interfaces --
------------------------------------
......@@ -14591,10 +14700,8 @@ package body Sem_Ch3 is
if Present (Full_View (Typ))
and then Etype (Typ) /= Full_View (Typ)
then
if Is_Interface (Etype (Typ))
and then not Contain_Interface (Etype (Typ), Ifaces)
then
Append_Elmt (Etype (Typ), Ifaces);
if Is_Interface (Etype (Typ)) then
Append_Unique_Elmt (Etype (Typ), Ifaces);
end if;
Collect_Implemented_Interfaces (Etype (Typ), Ifaces);
......@@ -14603,10 +14710,8 @@ package body Sem_Ch3 is
-- Non-private types
else
if Is_Interface (Etype (Typ))
and then not Contain_Interface (Etype (Typ), Ifaces)
then
Append_Elmt (Etype (Typ), Ifaces);
if Is_Interface (Etype (Typ)) then
Append_Unique_Elmt (Etype (Typ), Ifaces);
end if;
Collect_Implemented_Interfaces (Etype (Typ), Ifaces);
......@@ -14632,59 +14737,6 @@ package body Sem_Ch3 is
end if;
end Collect_Implemented_Interfaces;
-----------------------
-- Contain_Interface --
-----------------------
function Contain_Interface
(Iface : Entity_Id;
Ifaces : Elist_Id) return Boolean
is
Iface_Elmt : Elmt_Id;
begin
if Present (Ifaces) then
Iface_Elmt := First_Elmt (Ifaces);
while Present (Iface_Elmt) loop
if Node (Iface_Elmt) = Iface then
return True;
end if;
Next_Elmt (Iface_Elmt);
end loop;
end if;
return False;
end Contain_Interface;
---------------------------
-- Find_Hidden_Interface --
---------------------------
function Find_Hidden_Interface
(Src : Elist_Id;
Dest : Elist_Id) return Entity_Id
is
Iface : Entity_Id;
Iface_Elmt : Elmt_Id;
begin
if Present (Src) and then Present (Dest) then
Iface_Elmt := First_Elmt (Src);
while Present (Iface_Elmt) loop
Iface := Node (Iface_Elmt);
if not Contain_Interface (Iface, Dest) then
return Iface;
end if;
Next_Elmt (Iface_Elmt);
end loop;
end if;
return Empty;
end Find_Hidden_Interface;
-- Start of processing for Process_Full_View
begin
......@@ -14710,11 +14762,17 @@ package body Sem_Ch3 is
and then Is_Limited_Type (Priv_T)
and then not Is_Limited_Type (Full_T)
then
-- If pragma CPP_Class was applied to the private declaration
-- propagate the limitedness to the full-view
if Is_CPP_Class (Priv_T) then
Set_Is_Limited_Record (Full_T);
-- GNAT allow its own definition of Limited_Controlled to disobey
-- this rule in order in ease the implementation. The next test is
-- safe because Root_Controlled is defined in a private system child
if Etype (Full_T) = Full_View (RTE (RE_Root_Controlled)) then
elsif Etype (Full_T) = Full_View (RTE (RE_Root_Controlled)) then
Set_Is_Limited_Composite (Full_T);
else
Error_Msg_N
......@@ -14751,14 +14809,14 @@ package body Sem_Ch3 is
if Present (Iface) then
Error_Msg_NE ("interface & not implemented by full type " &
"('R'M'-2005 7.3 (7.3/2))", Priv_T, Iface);
"(RM-2005 7.3 (7.3/2))", Priv_T, Iface);
end if;
Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces);
if Present (Iface) then
Error_Msg_NE ("interface & not implemented by partial view " &
"('R'M'-2005 7.3 (7.3/2))", Full_T, Iface);
"(RM-2005 7.3 (7.3/2))", Full_T, Iface);
end if;
end;
end if;
......@@ -15356,7 +15414,7 @@ package body Sem_Ch3 is
-- the place where we put the check.
if not R_Check_Off then
R_Checks := Range_Check (R, T);
R_Checks := Get_Range_Checks (R, T);
-- Look up tree to find an appropriate insertion point.
-- This seems really junk code, and very brittle, couldn't
......@@ -15924,12 +15982,15 @@ package body Sem_Ch3 is
Type_Id : constant Name_Id := Chars (Typ);
function Names_T (Nam : Node_Id) return Boolean;
-- The record type has not been introduced in the current scope
-- yet, so we must examine the name of the type itself, either
-- an identifier T, or an expanded name of the form P.T, where
-- P denotes the current scope.
-------------
-- Names_T --
-------------
function Names_T (Nam : Node_Id) return Boolean is
begin
if Nkind (Nam) = N_Identifier then
......@@ -15941,8 +16002,8 @@ package body Sem_Ch3 is
return Chars (Prefix (Nam)) = Chars (Current_Scope);
elsif Nkind (Prefix (Nam)) = N_Selected_Component then
return Chars (Selector_Name (Prefix (Nam)))
= Chars (Current_Scope);
return Chars (Selector_Name (Prefix (Nam))) =
Chars (Current_Scope);
else
return False;
end if;
......@@ -15954,6 +16015,8 @@ package body Sem_Ch3 is
end if;
end Names_T;
-- Start of processing for Mentions_T
begin
if No (Access_To_Subprogram_Definition (Acc_Def)) then
Subt := Subtype_Mark (Acc_Def);
......
gcc/ada/sem_ch3.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, 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- --
......@@ -137,6 +137,13 @@ package Sem_Ch3 is
-- Note: one might expect this to be private to the package body, but
-- there is one rather unusual usage in package Exp_Dist.
function Find_Hidden_Interface
(Src : Elist_Id;
Dest : Elist_Id) return Entity_Id;
-- Ada 2005: Determine whether the interfaces in list Src are all present
-- in the list Dest. Return the first differing interface, or Empty
-- otherwise.
function Find_Type_Of_Subtype_Indic (S : Node_Id) return Entity_Id;
-- Given a subtype indication S (which is really an N_Subtype_Indication
-- node or a plain N_Identifier), find the type of the subtype mark.
......
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