Skip to content

R
riscv-gcc-1
Commit 7d7af38a by Javier Miranda Committed by Arnaud Charlet
Options

sem_ch3.ads, [...] (Check_Abstract_Overriding): Avoid generation of spurious… 

sem_ch3.ads, [...] (Check_Abstract_Overriding): Avoid generation of spurious error if parent is an interface type...

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

	* sem_ch3.ads, sem_ch3.adb (Check_Abstract_Overriding): Avoid
	generation of spurious error if parent is an interface type; caused
	because predefined primitive bodies will be generated later by
	Freeze_Record_Type.
	(Process_Subtype): The subtype inherits the Known_To_Have_Preelab_Init
	flag.
	(Derive_Subprograms): Handle derivations of predefined primitives
	after all the user-defined primitives to ensure that they are
	found in proper order in instantiations.
	(Add_Interface_Tag_Components, Inherit_Components): Update occurrences
	of Related_Interface to Related_Type.
	(Record_Type_Declaration): Minor reordering of calls to decorate the
	Tag component because the entity must have set its Ekind attribute
	before setting its Is_Tag attribute.
	(Analyze_Subtype_Declaration): In the case of subtypes with
	Private_Kind, inherit Known_To_Have_Preelab_Init from the parent.

From-SVN: r130883
parent 2242f4dd
Showing with 245 additions and 194 deletions
gcc/ada/sem_ch3.adb
......@@ -729,8 +729,8 @@ package body Sem_Ch3 is
-- function, scope is the current one, because it is the one of the
-- current type declaration.
if Nkind (Related_Nod) = N_Object_Declaration
or else Nkind (Related_Nod) = N_Access_Function_Definition
if Nkind_In (Related_Nod, N_Object_Declaration,
N_Access_Function_Definition)
then
Anon_Scope := Current_Scope;
......@@ -743,7 +743,7 @@ package body Sem_Ch3 is
-- unit, we must traverse the the tree to retrieve the proper entity.
elsif Nkind (Related_Nod) = N_Function_Specification
and then Nkind (Parent (N)) /= N_Parameter_Specification
and then Nkind (Parent (N)) /= N_Parameter_Specification
then
-- If the current scope is a protected type, the anonymous access
-- is associated with one of the protected operations, and must
......@@ -789,6 +789,9 @@ package body Sem_Ch3 is
(Anon_Type, E_Anonymous_Access_Subprogram_Type);
end if;
Set_Can_Use_Internal_Rep
(Anon_Type, not Always_Compatible_Rep_On_Target);
-- If the anonymous access is associated with a protected operation
-- create a reference to it after the enclosing protected definition
-- because the itype will be used in the subsequent bodies.
......@@ -932,16 +935,17 @@ package body Sem_Ch3 is
-- (Z : access T)))
D_Ityp := Associated_Node_For_Itype (Desig_Type);
while Nkind (D_Ityp) /= N_Full_Type_Declaration
and then Nkind (D_Ityp) /= N_Private_Type_Declaration
and then Nkind (D_Ityp) /= N_Private_Extension_Declaration
and then Nkind (D_Ityp) /= N_Procedure_Specification
and then Nkind (D_Ityp) /= N_Function_Specification
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
while not (Nkind_In (D_Ityp, N_Full_Type_Declaration,
N_Private_Type_Declaration,
N_Private_Extension_Declaration,
N_Procedure_Specification,
N_Function_Specification)
or else
Nkind_In (D_Ityp, N_Object_Declaration,
N_Object_Renaming_Declaration,
N_Formal_Type_Declaration,
N_Task_Type_Declaration,
N_Protected_Type_Declaration))
loop
D_Ityp := Parent (D_Ityp);
pragma Assert (D_Ityp /= Empty);
......@@ -949,22 +953,21 @@ package body Sem_Ch3 is
Set_Associated_Node_For_Itype (Desig_Type, D_Ityp);
if Nkind (D_Ityp) = N_Procedure_Specification
or else Nkind (D_Ityp) = N_Function_Specification
if Nkind_In (D_Ityp, N_Procedure_Specification,
N_Function_Specification)
then
Set_Scope (Desig_Type, Scope (Defining_Entity (D_Ityp)));
elsif Nkind (D_Ityp) = N_Full_Type_Declaration
or else Nkind (D_Ityp) = N_Object_Declaration
or else Nkind (D_Ityp) = N_Object_Renaming_Declaration
or else Nkind (D_Ityp) = N_Formal_Type_Declaration
elsif Nkind_In (D_Ityp, N_Full_Type_Declaration,
N_Object_Declaration,
N_Object_Renaming_Declaration,
N_Formal_Type_Declaration)
then
Set_Scope (Desig_Type, Scope (Defining_Identifier (D_Ityp)));
end if;
if Nkind (T_Def) = N_Access_Function_Definition then
if Nkind (Result_Definition (T_Def)) = N_Access_Definition then
declare
Acc : constant Node_Id := Result_Definition (T_Def);
......@@ -1057,6 +1060,8 @@ package body Sem_Ch3 is
Set_Ekind (T_Name, E_Access_Subprogram_Type);
end if;
Set_Can_Use_Internal_Rep (T_Name, not Always_Compatible_Rep_On_Target);
Set_Etype (T_Name, T_Name);
Init_Size_Align (T_Name);
Set_Directly_Designated_Type (T_Name, Desig_Type);
......@@ -1229,7 +1234,7 @@ package body Sem_Ch3 is
Set_Ekind (Tag, E_Component);
Set_Is_Tag (Tag);
Set_Is_Aliased (Tag);
Set_Related_Interface (Tag, Iface);
Set_Related_Type (Tag, Iface);
Init_Component_Location (Tag);
pragma Assert (Is_Frozen (Iface));
......@@ -1271,7 +1276,7 @@ package body Sem_Ch3 is
Set_Analyzed (Decl);
Set_Ekind (Offset, E_Component);
Set_Is_Aliased (Offset);
Set_Related_Interface (Offset, Iface);
Set_Related_Type (Offset, Iface);
Init_Component_Location (Offset);
Insert_After (Last_Tag, Decl);
Last_Tag := Decl;
......@@ -1620,7 +1625,6 @@ package body Sem_Ch3 is
declare
Sindic : constant Node_Id :=
Subtype_Indication (Component_Definition (N));
begin
if Nkind (Sindic) = N_Subtype_Indication
and then Present (Constraint (Sindic))
......@@ -1764,9 +1768,9 @@ package body Sem_Ch3 is
-- (This is needed in any case for early instantiations ???).
if No (Next_Node) then
if Nkind (Parent (L)) = N_Component_List
or else Nkind (Parent (L)) = N_Task_Definition
or else Nkind (Parent (L)) = N_Protected_Definition
if Nkind_In (Parent (L), N_Component_List,
N_Task_Definition,
N_Protected_Definition)
then
null;
......@@ -1810,12 +1814,13 @@ package body Sem_Ch3 is
-- not cause unwanted freezing at that point.
elsif not Analyzed (Next_Node)
and then (Nkind (Next_Node) = N_Subprogram_Body
or else Nkind (Next_Node) = N_Entry_Body
or else Nkind (Next_Node) = N_Package_Body
or else Nkind (Next_Node) = N_Protected_Body
or else Nkind (Next_Node) = N_Task_Body
or else Nkind (Next_Node) in N_Body_Stub)
and then (Nkind_In (Next_Node, N_Subprogram_Body,
N_Entry_Body,
N_Package_Body,
N_Protected_Body,
N_Task_Body)
or else
Nkind (Next_Node) in N_Body_Stub)
then
Adjust_D;
Freeze_All (Freeze_From, D);
......@@ -2070,9 +2075,7 @@ package body Sem_Ch3 is
return;
end if;
if Nkind (E) = N_Integer_Literal
or else Nkind (E) = N_Real_Literal
then
if Nkind_In (E, N_Integer_Literal, N_Real_Literal) then
Set_Etype (E, Etype (Id));
end if;
......@@ -2364,20 +2367,6 @@ package body Sem_Ch3 is
Set_Is_True_Constant (Id, True);
-- If the initialization expression is an access to constant,
-- it cannot be used with an access type.
if Is_Access_Type (Etype (E))
and then Is_Access_Constant (Etype (E))
and then Is_Access_Type (T)
and then not Is_Access_Constant (T)
then
Error_Msg_NE ("object of type& cannot be initialized with " &
"an access-to-constant expression",
E,
T);
end if;
-- If we are analyzing a constant declaration, set its completion
-- flag after analyzing the expression.
......@@ -3277,6 +3266,8 @@ package body Sem_Ch3 is
Set_Is_Limited_Record (Id, Is_Limited_Record (T));
Set_Has_Unknown_Discriminants
(Id, Has_Unknown_Discriminants (T));
Set_Known_To_Have_Preelab_Init
(Id, Known_To_Have_Preelab_Init (T));
if Is_Tagged_Type (T) then
Set_Is_Tagged_Type (Id);
......@@ -4307,9 +4298,7 @@ package body Sem_Ch3 is
-- Temporarily remove the current scope from the stack to add the new
-- declarations to the enclosing scope
if Nkind (N) = N_Object_Declaration
or else Nkind (N) = N_Access_Function_Definition
then
if Nkind_In (N, N_Object_Declaration, N_Access_Function_Definition) then
Analyze (Decl);
else
......@@ -4320,6 +4309,7 @@ package body Sem_Ch3 is
end if;
Set_Ekind (Anon, E_Anonymous_Access_Protected_Subprogram_Type);
Set_Can_Use_Internal_Rep (Anon, not Always_Compatible_Rep_On_Target);
return Anon;
end Replace_Anonymous_Access_To_Protected_Subprogram;
......@@ -4635,7 +4625,7 @@ package body Sem_Ch3 is
if Nkind (D_Constraint) = N_Identifier
and then Chars (D_Constraint) /=
Chars (Defining_Identifier (Disc_Spec))
Chars (Defining_Identifier (Disc_Spec))
then
Error_Msg_N ("new discriminants must constrain old ones",
D_Constraint);
......@@ -4967,8 +4957,11 @@ package body Sem_Ch3 is
Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Base));
Set_Parent (Implicit_Base, Parent (Derived_Type));
if Is_Discrete_Type (Parent_Base) or else
Is_Decimal_Fixed_Point_Type (Parent_Base)
-- Set RM Size for discrete type or decimal fixed-point type
-- Ordinary fixed-point is excluded, why???
if Is_Discrete_Type (Parent_Base)
or else Is_Decimal_Fixed_Point_Type (Parent_Base)
then
Set_RM_Size (Implicit_Base, RM_Size (Parent_Base));
end if;
......@@ -5314,8 +5307,8 @@ package body Sem_Ch3 is
and then Has_Discriminants (Full_View (Parent_Type))
then
if Has_Unknown_Discriminants (Parent_Type)
and then Nkind (Subtype_Indication (Type_Definition (N)))
= N_Subtype_Indication
and then Nkind (Subtype_Indication (Type_Definition (N))) =
N_Subtype_Indication
then
Error_Msg_N
("cannot constrain type with unknown discriminants",
......@@ -5973,7 +5966,7 @@ package body Sem_Ch3 is
Discriminant_Specs : constant Boolean :=
Present (Discriminant_Specifications (N));
Private_Extension : constant Boolean :=
(Nkind (N) = N_Private_Extension_Declaration);
Nkind (N) = N_Private_Extension_Declaration;
Constraint_Present : Boolean;
Inherit_Discrims : Boolean := False;
......@@ -7393,14 +7386,24 @@ package body Sem_Ch3 is
Set_Ekind (Def_Id, E_Record_Subtype);
end if;
-- Inherit preelaboration flag from base, for types for which it
-- may have been set: records, private types, protected types.
Set_Known_To_Have_Preelab_Init
(Def_Id, Known_To_Have_Preelab_Init (T));
elsif Ekind (T) = E_Task_Type then
Set_Ekind (Def_Id, E_Task_Subtype);
elsif Ekind (T) = E_Protected_Type then
Set_Ekind (Def_Id, E_Protected_Subtype);
Set_Known_To_Have_Preelab_Init
(Def_Id, Known_To_Have_Preelab_Init (T));
elsif Is_Private_Type (T) then
Set_Ekind (Def_Id, Subtype_Kind (Ekind (T)));
Set_Known_To_Have_Preelab_Init
(Def_Id, Known_To_Have_Preelab_Init (T));
elsif Is_Class_Wide_Type (T) then
Set_Ekind (Def_Id, E_Class_Wide_Subtype);
......@@ -7529,9 +7532,7 @@ package body Sem_Ch3 is
Analyze_And_Resolve (Bound, Base_Type (Par_T));
if Nkind (Bound) = N_Integer_Literal
or else Nkind (Bound) = N_Real_Literal
then
if Nkind_In (Bound, N_Integer_Literal, N_Real_Literal) then
New_Bound := New_Copy (Bound);
Set_Etype (New_Bound, Der_T);
Set_Analyzed (New_Bound);
......@@ -7826,8 +7827,6 @@ 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
......@@ -7835,15 +7834,15 @@ package body Sem_Ch3 is
and then not Comes_From_Source (Subp)
and then not Is_Abstract_Subprogram (Alias (Subp))
then
goto Next_Subp;
end if;
null;
if (Is_Abstract_Subprogram (Subp)
elsif (Is_Abstract_Subprogram (Subp)
or else Requires_Overriding (Subp)
or else (Has_Controlling_Result (Subp)
and then Present (Alias_Subp)
and then not Comes_From_Source (Subp)
and then Sloc (Subp) = Sloc (First_Subtype (T))))
or else
(Has_Controlling_Result (Subp)
and then Present (Alias_Subp)
and then not Comes_From_Source (Subp)
and then Sloc (Subp) = Sloc (First_Subtype (T))))
and then not Is_TSS (Subp, TSS_Stream_Input)
and then not Is_TSS (Subp, TSS_Stream_Output)
and then not Is_Abstract_Type (T)
......@@ -7851,6 +7850,7 @@ package body Sem_Ch3 is
and then Chars (Subp) /= Name_uDisp_Asynchronous_Select
and then Chars (Subp) /= Name_uDisp_Conditional_Select
and then Chars (Subp) /= Name_uDisp_Get_Prim_Op_Kind
and then Chars (Subp) /= Name_uDisp_Requeue
and then Chars (Subp) /= Name_uDisp_Timed_Select
-- Ada 2005 (AI-251): Do not consider hidden entities associated
......@@ -7877,6 +7877,7 @@ package body Sem_Ch3 is
-- Exp_Ch3.Make_Controlling_Wrapper_Functions).
Type_Def := Type_Definition (Parent (T));
if Nkind (Type_Def) = N_Derived_Type_Definition
and then Present (Record_Extension_Part (Type_Def))
and then
......@@ -7888,32 +7889,46 @@ package body Sem_Ch3 is
or else Requires_Overriding (Subp)
or else Is_Access_Type (Etype (Subp)))
then
Error_Msg_NE
("type must be declared abstract or & overridden",
T, Subp);
-- The body of predefined primitives of tagged types derived
-- from interface types are generated later by Freeze_Type.
-- Traverse the whole chain of aliased subprograms to
-- complete the error notification. This is especially
-- useful for traceability of the chain of entities when the
-- subprogram corresponds with an interface subprogram
-- (which might be defined in another package)
if Is_Predefined_Dispatching_Operation (Subp)
and then Is_Abstract_Subprogram (Alias_Subp)
and then Is_Interface
(Root_Type (Find_Dispatching_Type (Subp)))
then
null;
if Present (Alias_Subp) then
declare
E : Entity_Id;
else
Error_Msg_NE
("type must be declared abstract or & overridden",
T, Subp);
begin
E := Subp;
while Present (Alias (E)) loop
Error_Msg_Sloc := Sloc (E);
Error_Msg_NE ("\& has been inherited #", T, Subp);
E := Alias (E);
end loop;
-- Traverse the whole chain of aliased subprograms to
-- complete the error notification. This is especially
-- useful for traceability of the chain of entities when
-- the subprogram corresponds with an interface
-- subprogram (which may be defined in another package).
if Present (Alias_Subp) then
declare
E : Entity_Id;
begin
E := Subp;
while Present (Alias (E)) loop
Error_Msg_Sloc := Sloc (E);
Error_Msg_NE
("\& has been inherited #", T, Subp);
E := Alias (E);
end loop;
Error_Msg_Sloc := Sloc (E);
Error_Msg_NE
("\& has been inherited from subprogram #", T, Subp);
end;
Error_Msg_Sloc := Sloc (E);
Error_Msg_NE
("\& has been inherited from subprogram #",
T, Subp);
end;
end if;
end if;
-- Ada 2005 (AI-345): Protected or task type implementing
......@@ -7960,8 +7975,36 @@ package body Sem_Ch3 is
end if;
end if;
<<Next_Subp>>
Next_Elmt (Elmt);
-- Ada 2005 (AI05-0030): Inspect hidden subprograms which provide
-- the mapping between interface and implementing type primitives.
-- If the interface alias is marked as Implemented_By_Entry, the
-- alias must be an entry wrapper.
if Ada_Version >= Ada_05
and then Is_Hidden (Subp)
and then Present (Abstract_Interface_Alias (Subp))
and then Implemented_By_Entry (Abstract_Interface_Alias (Subp))
and then Present (Alias_Subp)
and then
(not Is_Primitive_Wrapper (Alias_Subp)
or else Ekind (Wrapped_Entity (Alias_Subp)) /= E_Entry)
then
declare
Error_Ent : Entity_Id := T;
begin
if Is_Concurrent_Record_Type (Error_Ent) then
Error_Ent := Corresponding_Concurrent_Type (Error_Ent);
end if;
Error_Msg_Node_2 := Abstract_Interface_Alias (Subp);
Error_Msg_NE
("type & must implement abstract subprogram & with an entry",
Error_Ent, Error_Ent);
end;
end if;
Next_Elmt (Elmt);
end loop;
end Check_Abstract_Overriding;
......@@ -8125,8 +8168,8 @@ package body Sem_Ch3 is
elsif Is_Overloadable (E)
and then Current_Entity_In_Scope (E) /= E
then
-- It may be that the completion is mistyped and appears
-- as a distinct overloading of the entity.
-- It may be that the completion is mistyped and appears as
-- a distinct overloading of the entity.
declare
Candidate : constant Entity_Id :=
......@@ -8163,18 +8206,17 @@ package body Sem_Ch3 is
if Is_Intrinsic_Subprogram (E) then
null;
-- The following situation requires special handling: a child
-- unit that appears in the context clause of the body of its
-- parent:
-- The following situation requires special handling: a child unit
-- that appears in the context clause of the body of its parent:
-- procedure Parent.Child (...);
-- with Parent.Child;
-- package body Parent is
-- Here Parent.Child appears as a local entity, but should not
-- be flagged as requiring completion, because it is a
-- compilation unit.
-- Here Parent.Child appears as a local entity, but should not be
-- flagged as requiring completion, because it is a compilation
-- unit.
-- Ignore missing completion for a subprogram that does not come from
-- source (including the _Call primitive operation of RAS types,
......@@ -8359,7 +8401,7 @@ package body Sem_Ch3 is
else
Error_Msg_N
("initialization of limited object requires agggregate "
("initialization of limited object requires aggregate "
& "or function call", Exp);
end if;
end if;
......@@ -11086,10 +11128,10 @@ package body Sem_Ch3 is
Next_Elmt (Elmt);
end loop;
-- Complete the derivation of the interface subprograms. Assignate to
-- each entity associated with abstract interfaces their aliased entity
-- and complete their decoration as hidden interface entities that will
-- be used later to build the secondary dispatch tables.
-- Complete the derivation of the interface subprograms. Assign to each
-- entity associated with abstract interfaces their aliased entity and
-- complete their decoration as hidden interface entities that will be
-- used later to build the secondary dispatch tables.
if not Is_Empty_Elmt_List (Ifaces_List) then
if Ekind (Parent_Type) = E_Record_Type_With_Private
......@@ -11605,13 +11647,14 @@ package body Sem_Ch3 is
------------------------
procedure Derive_Subprograms
(Parent_Type : Entity_Id;
Derived_Type : Entity_Id;
Generic_Actual : Entity_Id := Empty)
(Parent_Type : Entity_Id;
Derived_Type : Entity_Id;
Generic_Actual : Entity_Id := Empty)
is
Op_List : constant Elist_Id :=
Collect_Primitive_Operations (Parent_Type);
Ifaces_List : constant Elist_Id := New_Elmt_List;
Predef_Prims : constant Elist_Id := New_Elmt_List;
Act_List : Elist_Id;
Act_Elmt : Elmt_Id;
Elmt : Elmt_Id;
......@@ -11629,7 +11672,9 @@ package body Sem_Ch3 is
Parent_Base := Parent_Type;
end if;
-- Derive primitives inherited from the parent
-- Derive primitives inherited from the parent. Note that if the generic
-- actual is present, this is not really a type derivation, it is a
-- completion within an instance.
if Present (Generic_Actual) then
Act_List := Collect_Primitive_Operations (Generic_Actual);
......@@ -11652,18 +11697,27 @@ package body Sem_Ch3 is
then
null;
-- We derive predefined primitives in a later round to ensure that
-- they are always added to the list of primitives after user
-- defined primitives (because predefined primitives have to be
-- skipped when matching the operations of a parent interface to
-- those of a concrete type). However it is unclear why those
-- primitives would be needed in an instantiation???
elsif Is_Predefined_Dispatching_Operation (Subp) then
Append_Elmt (Subp, Predef_Prims);
elsif No (Generic_Actual) then
Derive_Subprogram (New_Subp, Subp, Derived_Type, Parent_Base);
-- Ada 2005 (AI-251): Add the derivation of an abstract
-- interface primitive to the list of entities to which
-- we have to associate an aliased entity.
-- Ada 2005 (AI-251): Add derivation of an abstract interface
-- primitive to the list of entities to which we have to
-- associate an aliased entity.
if Ada_Version >= Ada_05
and then Is_Dispatching_Operation (Subp)
and then Present (Find_Dispatching_Type (Subp))
and then Is_Interface (Find_Dispatching_Type (Subp))
and then not Is_Predefined_Dispatching_Operation (Subp)
then
Append_Elmt (New_Subp, Ifaces_List);
end if;
......@@ -11714,13 +11768,12 @@ package body Sem_Ch3 is
Next_Elmt (Elmt);
end loop;
-- Inherit additional operations from progenitor interfaces.
-- However, if the derived type is a generic actual, there
-- are not new primitive operations for the type, because
-- it has those of the actual, so nothing needs to be done.
-- The renamings generated above are not primitive operations,
-- and their purpose is simply to make the proper operations
-- visible within an instantiation.
-- Inherit additional operations from progenitor interfaces. However,
-- if the derived type is a generic actual, there are not new primitive
-- operations for the type, because it has those of the actual, so
-- nothing needs to be done. The renamings generated above are not
-- primitive operations, and their purpose is simply to make the proper
-- operations visible within an instantiation.
if Ada_Version >= Ada_05
and then Is_Tagged_Type (Derived_Type)
......@@ -11728,6 +11781,17 @@ package body Sem_Ch3 is
then
Derive_Interface_Subprograms (Parent_Type, Derived_Type, Ifaces_List);
end if;
-- Derive predefined primitives
if not Is_Empty_Elmt_List (Predef_Prims) then
Elmt := First_Elmt (Predef_Prims);
while Present (Elmt) loop
Derive_Subprogram
(New_Subp, Node (Elmt), Derived_Type, Parent_Base);
Next_Elmt (Elmt);
end loop;
end if;
end Derive_Subprograms;
--------------------------------
......@@ -11795,12 +11859,12 @@ package body Sem_Ch3 is
Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc);
-- Because the implicit base is used in the conversion of the bounds,
-- we have to freeze it now. This is similar to what is done for
-- numeric types, and it equally suspicious, but otherwise a non-
-- static bound will have a reference to an unfrozen type, which is
-- rejected by Gigi (???). This requires specific care for definition
-- of stream attributes. For details, see comments at the end of
-- Because the implicit base is used in the conversion of the bounds, we
-- have to freeze it now. This is similar to what is done for numeric
-- types, and it equally suspicious, but otherwise a non-static bound
-- will have a reference to an unfrozen type, which is rejected by Gigi
-- (???). This requires specific care for definition of stream
-- attributes. For details, see comments at the end of
-- Build_Derived_Numeric_Type.
Freeze_Before (N, Implicit_Base);
......@@ -12495,9 +12559,9 @@ package body Sem_Ch3 is
Enter_Name (Id);
New_Id := Id;
elsif Nkind (N) /= N_Full_Type_Declaration
and then Nkind (N) /= N_Task_Type_Declaration
and then Nkind (N) /= N_Protected_Type_Declaration
elsif not Nkind_In (N, N_Full_Type_Declaration,
N_Task_Type_Declaration,
N_Protected_Type_Declaration)
then
-- Completion must be a full type declarations (RM 7.3(4))
......@@ -12542,17 +12606,15 @@ package body Sem_Ch3 is
New_Id := Id;
elsif Ekind (Prev) = E_Private_Type
and then
(Nkind (N) = N_Task_Type_Declaration
or else Nkind (N) = N_Protected_Type_Declaration)
and then Nkind_In (N, N_Task_Type_Declaration,
N_Protected_Type_Declaration)
then
Error_Msg_N
("completion of nonlimited type cannot be limited", N);
elsif Ekind (Prev) = E_Record_Type_With_Private
and then
(Nkind (N) = N_Task_Type_Declaration
or else Nkind (N) = N_Protected_Type_Declaration)
and then Nkind_In (N, N_Task_Type_Declaration,
N_Protected_Type_Declaration)
then
if not Is_Limited_Record (Prev) then
Error_Msg_N
......@@ -12569,8 +12631,8 @@ package body Sem_Ch3 is
-- 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
elsif Nkind_In (N, N_Task_Type_Declaration,
N_Protected_Type_Declaration)
then
null;
......@@ -12643,8 +12705,8 @@ package body Sem_Ch3 is
if Is_Type (Prev)
and then (Is_Tagged_Type (Prev)
or else Present (Class_Wide_Type (Prev)))
and then (Nkind (N) /= N_Task_Type_Declaration
and then Nkind (N) /= N_Protected_Type_Declaration)
and then not Nkind_In (N, N_Task_Type_Declaration,
N_Protected_Type_Declaration)
then
-- The full declaration is either a tagged record or an
-- extension otherwise this is an error
......@@ -12706,8 +12768,8 @@ package body Sem_Ch3 is
-- Case of an anonymous array subtype
if Def_Kind = N_Constrained_Array_Definition
or else Def_Kind = N_Unconstrained_Array_Definition
if Nkind_In (Def_Kind, N_Constrained_Array_Definition,
N_Unconstrained_Array_Definition)
then
T := Empty;
Array_Type_Declaration (T, Obj_Def);
......@@ -13457,7 +13519,7 @@ package body Sem_Ch3 is
-- secondary tags of the parent.
if Ekind (Component) = E_Component
and then Present (Related_Interface (Component))
and then Present (Related_Type (Component))
then
null;
......@@ -13568,22 +13630,16 @@ package body Sem_Ch3 is
return Constraint_Kind = N_Range_Constraint;
when Decimal_Fixed_Point_Kind =>
return
Constraint_Kind = N_Digits_Constraint
or else
Constraint_Kind = N_Range_Constraint;
return Nkind_In (Constraint_Kind, N_Digits_Constraint,
N_Range_Constraint);
when Ordinary_Fixed_Point_Kind =>
return
Constraint_Kind = N_Delta_Constraint
or else
Constraint_Kind = N_Range_Constraint;
return Nkind_In (Constraint_Kind, N_Delta_Constraint,
N_Range_Constraint);
when Float_Kind =>
return
Constraint_Kind = N_Digits_Constraint
or else
Constraint_Kind = N_Range_Constraint;
return Nkind_In (Constraint_Kind, N_Digits_Constraint,
N_Range_Constraint);
when Access_Kind |
Array_Kind |
......@@ -15520,19 +15576,14 @@ package body Sem_Ch3 is
Type_Decl := Parent (R);
while Present (Type_Decl) and then not
(Nkind (Type_Decl) = N_Full_Type_Declaration
or else
Nkind (Type_Decl) = N_Subtype_Declaration
or else
Nkind (Type_Decl) = N_Loop_Statement
or else
Nkind (Type_Decl) = N_Task_Type_Declaration
or else
Nkind (Type_Decl) = N_Single_Task_Declaration
(Nkind_In (Type_Decl, N_Full_Type_Declaration,
N_Subtype_Declaration,
N_Loop_Statement,
N_Task_Type_Declaration)
or else
Nkind (Type_Decl) = N_Protected_Type_Declaration
or else
Nkind (Type_Decl) = N_Single_Protected_Declaration)
Nkind_In (Type_Decl, N_Single_Task_Declaration,
N_Protected_Type_Declaration,
N_Single_Protected_Declaration))
loop
Type_Decl := Parent (Type_Decl);
end loop;
......@@ -15550,8 +15601,8 @@ package body Sem_Ch3 is
begin
Indic := Parent (R);
while Present (Indic) and then not
(Nkind (Indic) = N_Subtype_Indication)
while Present (Indic)
and then Nkind (Indic) /= N_Subtype_Indication
loop
Indic := Parent (Indic);
end loop;
......@@ -15694,7 +15745,6 @@ package body Sem_Ch3 is
-- Case of no constraints present
if Nkind (S) /= N_Subtype_Indication then
Find_Type (S);
Check_Incomplete (S);
P := Parent (S);
......@@ -15710,18 +15760,21 @@ package body Sem_Ch3 is
Error_Msg_N ("`NOT NULL` only allowed for an access type", S);
end if;
-- The following is ugly, can't we have a range or even a flag???
May_Have_Null_Exclusion :=
Nkind (P) = N_Access_Definition
or else Nkind (P) = N_Access_Function_Definition
or else Nkind (P) = N_Access_Procedure_Definition
or else Nkind (P) = N_Access_To_Object_Definition
or else Nkind (P) = N_Allocator
or else Nkind (P) = N_Component_Definition
or else Nkind (P) = N_Derived_Type_Definition
or else Nkind (P) = N_Discriminant_Specification
or else Nkind (P) = N_Object_Declaration
or else Nkind (P) = N_Parameter_Specification
or else Nkind (P) = N_Subtype_Declaration;
Nkind_In (P, N_Access_Definition,
N_Access_Function_Definition,
N_Access_Procedure_Definition,
N_Access_To_Object_Definition,
N_Allocator,
N_Component_Definition)
or else
Nkind_In (P, N_Derived_Type_Definition,
N_Discriminant_Specification,
N_Object_Declaration,
N_Parameter_Specification,
N_Subtype_Declaration);
-- Create an Itype that is a duplicate of Entity (S) but with the
-- null-exclusion attribute
......@@ -16079,7 +16132,6 @@ package body Sem_Ch3 is
------------------
function Designates_T (Subt : Node_Id) return Boolean is
Type_Id : constant Name_Id := Chars (Typ);
function Names_T (Nam : Node_Id) return Boolean;
......@@ -16108,9 +16160,11 @@ package body Sem_Ch3 is
else
return False;
end if;
else
return False;
end if;
else
return False;
end if;
......@@ -16143,8 +16197,8 @@ package body Sem_Ch3 is
or else
(Is_Class_Wide_Type (Entity (Subt))
and then
Chars (Etype (Base_Type (Entity (Subt))))
= Type_Id));
Chars (Etype (Base_Type (Entity (Subt)))) =
Type_Id));
end if;
-- A reference to the current type may appear as the prefix of
......@@ -16168,7 +16222,7 @@ package body Sem_Ch3 is
Param_Spec : Node_Id;
Acc_Subprg : constant Node_Id :=
Access_To_Subprogram_Definition (Acc_Def);
Access_To_Subprogram_Definition (Acc_Def);
begin
if No (Acc_Subprg) then
......@@ -16203,7 +16257,6 @@ package body Sem_Ch3 is
end if;
return False;
end Mentions_T;
-- Start of processing for Check_Anonymous_Access_Components
......@@ -16445,9 +16498,9 @@ package body Sem_Ch3 is
Tag_Comp := Make_Defining_Identifier (Sloc (Def), Name_uTag);
Enter_Name (Tag_Comp);
Set_Ekind (Tag_Comp, E_Component);
Set_Is_Tag (Tag_Comp);
Set_Is_Aliased (Tag_Comp);
Set_Ekind (Tag_Comp, E_Component);
Set_Etype (Tag_Comp, RTE (RE_Tag));
Set_DT_Entry_Count (Tag_Comp, No_Uint);
Set_Original_Record_Component (Tag_Comp, Tag_Comp);
......
gcc/ada/sem_ch3.ads
......@@ -120,18 +120,16 @@ package Sem_Ch3 is
-- subprogram of the parent type.
procedure Derive_Subprograms
(Parent_Type : Entity_Id;
Derived_Type : Entity_Id;
Generic_Actual : Entity_Id := Empty);
(Parent_Type : Entity_Id;
Derived_Type : Entity_Id;
Generic_Actual : Entity_Id := Empty);
-- To complete type derivation, collect/retrieve the primitive operations
-- of the parent type, and replace the subsidiary subtypes with the derived
-- type, to build the specs of the inherited ops. For generic actuals, the
-- mapping of the primitive operations to those of the parent type is also
-- done by rederiving the operations within the instance. For tagged types,
-- the derived subprograms are aliased to those of the actual, not those of
-- the ancestor. The last two params are used in case of derivation from
-- abstract interface types: No_Predefined_Prims is used to avoid the
-- derivation of predefined primitives from an abstract interface.
-- the ancestor.
--
-- Note: one might expect this to be private to the package body, but
-- there is one rather unusual usage in package Exp_Dist.
......
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