Skip to content

R
riscv-gcc-1
Commit 71d9e9f2 by Ed Schonberg Committed by Arnaud Charlet
Options

sem_ch3.adb (Build_Derived_Record_Type): Set First/Last entity of class_wide… 

sem_ch3.adb (Build_Derived_Record_Type): Set First/Last entity of class_wide type after component list has been inherited.

2004-10-04  Ed Schonberg  <schonberg@gnat.com>

	* sem_ch3.adb (Build_Derived_Record_Type): Set First/Last entity of
	class_wide type after component list has been inherited.

From-SVN: r88497
parent 0b525bee
Showing with 144 additions and 185 deletions
gcc/ada/ChangeLog
2004-10-04 Ed Schonberg <schonberg@gnat.com> 2004-10-04 Ed Schonberg <schonberg@gnat.com>
* sem_ch3.adb (Build_Derived_Record_Type): Set First/Last entity of
class_wide type after component list has been inherited.
2004-10-04 Ed Schonberg <schonberg@gnat.com>
* sem_ch12.adb (Check_Generic_Actuals): New predicate * sem_ch12.adb (Check_Generic_Actuals): New predicate
Denotes_Previous_Actual, to handle properly the case of a private Denotes_Previous_Actual, to handle properly the case of a private
actual that is also the component type of a subsequent array actual. actual that is also the component type of a subsequent array actual.
......
gcc/ada/sem_ch3.adb
...@@ -801,7 +801,6 @@ package body Sem_Ch3 is ...@@ -801,7 +801,6 @@ package body Sem_Ch3 is
Formal := First_Formal (Desig_Type); Formal := First_Formal (Desig_Type);
while Present (Formal) loop while Present (Formal) loop
if Ekind (Formal) /= E_In_Parameter if Ekind (Formal) /= E_In_Parameter
and then Nkind (T_Def) = N_Access_Function_Definition and then Nkind (T_Def) = N_Access_Function_Definition
then then
...@@ -961,7 +960,6 @@ package body Sem_Ch3 is ...@@ -961,7 +960,6 @@ package body Sem_Ch3 is
function Contains_POC (Constr : Node_Id) return Boolean is function Contains_POC (Constr : Node_Id) return Boolean is
begin begin
case Nkind (Constr) is case Nkind (Constr) is
when N_Attribute_Reference => when N_Attribute_Reference =>
return Attribute_Name (Constr) = Name_Access return Attribute_Name (Constr) = Name_Access
and and
...@@ -976,6 +974,7 @@ package body Sem_Ch3 is ...@@ -976,6 +974,7 @@ package body Sem_Ch3 is
when N_Index_Or_Discriminant_Constraint => when N_Index_Or_Discriminant_Constraint =>
declare declare
IDC : Node_Id := First (Constraints (Constr)); IDC : Node_Id := First (Constraints (Constr));
begin begin
while Present (IDC) loop while Present (IDC) loop
...@@ -993,7 +992,7 @@ package body Sem_Ch3 is ...@@ -993,7 +992,7 @@ package body Sem_Ch3 is
when N_Range => when N_Range =>
return Denotes_Discriminant (Low_Bound (Constr)) return Denotes_Discriminant (Low_Bound (Constr))
or or else
Denotes_Discriminant (High_Bound (Constr)); Denotes_Discriminant (High_Bound (Constr));
when N_Range_Constraint => when N_Range_Constraint =>
...@@ -1118,7 +1117,7 @@ package body Sem_Ch3 is ...@@ -1118,7 +1117,7 @@ package body Sem_Ch3 is
end if; end if;
-- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry
-- out some static checks -- out some static checks.
if Ada_Version >= Ada_05 if Ada_Version >= Ada_05
and then (Null_Exclusion_Present (Component_Definition (N)) and then (Null_Exclusion_Present (Component_Definition (N))
...@@ -1135,7 +1134,7 @@ package body Sem_Ch3 is ...@@ -1135,7 +1134,7 @@ package body Sem_Ch3 is
P := Private_Component (T); P := Private_Component (T);
if Present (P) then if Present (P) then
-- Check for circular definitions. -- Check for circular definitions
if P = Any_Type then if P = Any_Type then
Set_Etype (Id, Any_Type); Set_Etype (Id, Any_Type);
...@@ -1651,6 +1650,7 @@ package body Sem_Ch3 is ...@@ -1651,6 +1650,7 @@ package body Sem_Ch3 is
Set_Completion_Referenced (Id); Set_Completion_Referenced (Id);
if Error_Posted (N) then if Error_Posted (N) then
-- Type mismatch or illegal redeclaration, Do not analyze -- Type mismatch or illegal redeclaration, Do not analyze
-- expression to avoid cascaded errors. -- expression to avoid cascaded errors.
...@@ -1782,7 +1782,7 @@ package body Sem_Ch3 is ...@@ -1782,7 +1782,7 @@ package body Sem_Ch3 is
Check_Initialization (T, E); Check_Initialization (T, E);
end if; end if;
Set_Etype (Id, T); -- may be overridden later on. Set_Etype (Id, T); -- may be overridden later on
Resolve (E, T); Resolve (E, T);
Check_Unset_Reference (E); Check_Unset_Reference (E);
...@@ -1815,6 +1815,7 @@ package body Sem_Ch3 is ...@@ -1815,6 +1815,7 @@ package body Sem_Ch3 is
if Is_Abstract (T) and then Comes_From_Source (N) then if Is_Abstract (T) and then Comes_From_Source (N) then
Error_Msg_N ("type of object cannot be abstract", Error_Msg_N ("type of object cannot be abstract",
Object_Definition (N)); Object_Definition (N));
if Is_CPP_Class (T) then if Is_CPP_Class (T) then
Error_Msg_NE ("\} may need a cpp_constructor", Error_Msg_NE ("\} may need a cpp_constructor",
Object_Definition (N), T); Object_Definition (N), T);
...@@ -1916,7 +1917,7 @@ package body Sem_Ch3 is ...@@ -1916,7 +1917,7 @@ package body Sem_Ch3 is
elsif Nkind (E) = N_Raise_Constraint_Error then elsif Nkind (E) = N_Raise_Constraint_Error then
-- Aggregate is statically illegal. Place back in declaration -- Aggregate is statically illegal. Place back in declaration.
Set_Expression (N, E); Set_Expression (N, E);
Set_No_Initialization (N, False); Set_No_Initialization (N, False);
...@@ -2028,7 +2029,6 @@ package body Sem_Ch3 is ...@@ -2028,7 +2029,6 @@ package body Sem_Ch3 is
then then
if not Is_Library_Level_Entity (Id) then if not Is_Library_Level_Entity (Id) then
Check_Restriction (No_Nested_Finalization, N); Check_Restriction (No_Nested_Finalization, N);
else else
Validate_Controlled_Object (Id); Validate_Controlled_Object (Id);
end if; end if;
...@@ -2112,7 +2112,6 @@ package body Sem_Ch3 is ...@@ -2112,7 +2112,6 @@ package body Sem_Ch3 is
if Is_Library_Level_Entity (Id) then if Is_Library_Level_Entity (Id) then
Check_Restriction (Max_Tasks, N, Count_Tasks (Etype (Id))); Check_Restriction (Max_Tasks, N, Count_Tasks (Etype (Id)));
else else
Check_Restriction (Max_Tasks, N); Check_Restriction (Max_Tasks, N);
Check_Restriction (No_Task_Hierarchy, N); Check_Restriction (No_Task_Hierarchy, N);
...@@ -2125,9 +2124,7 @@ package body Sem_Ch3 is ...@@ -2125,9 +2124,7 @@ package body Sem_Ch3 is
-- will be raised at run-time since we can't have two tasks with -- will be raised at run-time since we can't have two tasks with
-- entries at the same address. -- entries at the same address.
if Is_Task_Type (Etype (Id)) if Is_Task_Type (Etype (Id)) and then More_Ids (N) then
and then More_Ids (N)
then
declare declare
E : Entity_Id; E : Entity_Id;
...@@ -2165,7 +2162,6 @@ package body Sem_Ch3 is ...@@ -2165,7 +2162,6 @@ package body Sem_Ch3 is
then then
declare declare
Val : constant Node_Id := Constant_Value (Entity (E)); Val : constant Node_Id := Constant_Value (Entity (E));
begin begin
if Present (Val) if Present (Val)
and then Nkind (Val) = N_String_Literal and then Nkind (Val) = N_String_Literal
...@@ -2229,7 +2225,6 @@ package body Sem_Ch3 is ...@@ -2229,7 +2225,6 @@ package body Sem_Ch3 is
procedure Analyze_Others_Choice (N : Node_Id) is procedure Analyze_Others_Choice (N : Node_Id) is
pragma Warnings (Off, N); pragma Warnings (Off, N);
begin begin
null; null;
end Analyze_Others_Choice; end Analyze_Others_Choice;
...@@ -2240,7 +2235,6 @@ package body Sem_Ch3 is ...@@ -2240,7 +2235,6 @@ package body Sem_Ch3 is
procedure Analyze_Per_Use_Expression (N : Node_Id; T : Entity_Id) is procedure Analyze_Per_Use_Expression (N : Node_Id; T : Entity_Id) is
Save_In_Default_Expression : constant Boolean := In_Default_Expression; Save_In_Default_Expression : constant Boolean := In_Default_Expression;
begin begin
In_Default_Expression := True; In_Default_Expression := True;
Pre_Analyze_And_Resolve (N, T); Pre_Analyze_And_Resolve (N, T);
...@@ -3040,7 +3034,6 @@ package body Sem_Ch3 is ...@@ -3040,7 +3034,6 @@ package body Sem_Ch3 is
end if; end if;
Nb_Index := 1; Nb_Index := 1;
while Present (Index) loop while Present (Index) loop
Analyze (Index); Analyze (Index);
Make_Index (Index, P, Related_Id, Nb_Index); Make_Index (Index, P, Related_Id, Nb_Index);
...@@ -3581,7 +3574,6 @@ package body Sem_Ch3 is ...@@ -3581,7 +3574,6 @@ package body Sem_Ch3 is
(Derived_Type, Corresponding_Record_Type (Parent_Type)); (Derived_Type, Corresponding_Record_Type (Parent_Type));
if Constraint_Present then if Constraint_Present then
if not Has_Discriminants (Parent_Type) then if not Has_Discriminants (Parent_Type) then
Error_Msg_N ("untagged parent must have discriminants", N); Error_Msg_N ("untagged parent must have discriminants", N);
...@@ -3643,9 +3635,7 @@ package body Sem_Ch3 is ...@@ -3643,9 +3635,7 @@ package body Sem_Ch3 is
end if; end if;
if Present (Discriminant_Specifications (N)) then if Present (Discriminant_Specifications (N)) then
Old_Disc := First_Discriminant (Parent_Type); Old_Disc := First_Discriminant (Parent_Type);
while Present (Old_Disc) loop while Present (Old_Disc) loop
if No (Next_Entity (Old_Disc)) if No (Next_Entity (Old_Disc))
...@@ -3824,7 +3814,6 @@ package body Sem_Ch3 is ...@@ -3824,7 +3814,6 @@ package body Sem_Ch3 is
-- must be implicitly converted to the new type. -- must be implicitly converted to the new type.
if Nkind (Indic) = N_Subtype_Indication then if Nkind (Indic) = N_Subtype_Indication then
declare declare
R : constant Node_Id := R : constant Node_Id :=
Range_Expression (Constraint (Indic)); Range_Expression (Constraint (Indic));
...@@ -3856,7 +3845,6 @@ package body Sem_Ch3 is ...@@ -3856,7 +3845,6 @@ package body Sem_Ch3 is
Prefix => Prefix =>
New_Occurrence_Of (Entity (Prefix (R)), Loc))); New_Occurrence_Of (Entity (Prefix (R)), Loc)));
end if; end if;
end; end;
else else
...@@ -4149,7 +4137,6 @@ package body Sem_Ch3 is ...@@ -4149,7 +4137,6 @@ package body Sem_Ch3 is
return; return;
elsif Has_Discriminants (Parent_Type) then elsif Has_Discriminants (Parent_Type) then
if Present (Full_View (Parent_Type)) then if Present (Full_View (Parent_Type)) then
if not Is_Completion then if not Is_Completion then
...@@ -4173,9 +4160,8 @@ package body Sem_Ch3 is ...@@ -4173,9 +4160,8 @@ package body Sem_Ch3 is
-- serve as the underlying full view of the derived type. -- serve as the underlying full view of the derived type.
if No (Discriminant_Specifications (N)) then if No (Discriminant_Specifications (N)) then
if Nkind (Subtype_Indication (Type_Definition (N))) =
if Nkind (Subtype_Indication (Type_Definition (N))) N_Subtype_Indication
= N_Subtype_Indication
then then
Build_Underlying_Full_View (N, Derived_Type, Parent_Type); Build_Underlying_Full_View (N, Derived_Type, Parent_Type);
...@@ -4220,8 +4206,8 @@ package body Sem_Ch3 is ...@@ -4220,8 +4206,8 @@ package body Sem_Ch3 is
if not Is_Tagged_Type (Parent_Type) then if not Is_Tagged_Type (Parent_Type) then
Build_Derived_Record_Type Build_Derived_Record_Type
(Full_Decl, Parent_Type, Full_Der, False); (Full_Decl, Parent_Type, Full_Der, False);
else
else
-- If full view of parent is tagged, the completion -- If full view of parent is tagged, the completion
-- inherits the proper primitive operations. -- inherits the proper primitive operations.
...@@ -4334,8 +4320,8 @@ package body Sem_Ch3 is ...@@ -4334,8 +4320,8 @@ package body Sem_Ch3 is
else else
-- Untagged type, No discriminants on either view -- Untagged type, No discriminants on either view
if Nkind (Subtype_Indication (Type_Definition (N))) if Nkind (Subtype_Indication (Type_Definition (N))) =
= N_Subtype_Indication N_Subtype_Indication
then then
Error_Msg_N Error_Msg_N
("illegal constraint on type without discriminants", N); ("illegal constraint on type without discriminants", N);
...@@ -4367,17 +4353,17 @@ package body Sem_Ch3 is ...@@ -4367,17 +4353,17 @@ package body Sem_Ch3 is
-- view of the parent type. In order to get proper visibility, -- view of the parent type. In order to get proper visibility,
-- we install the parent scope and its declarations. -- we install the parent scope and its declarations.
-- ??? if the parent is untagged private and its -- ??? if the parent is untagged private and its completion is
-- completion is tagged, this mechanism will not -- tagged, this mechanism will not work because we cannot derive
-- work because we cannot derive from the tagged -- from the tagged full view unless we have an extension
-- full view unless we have an extension
if Present (Full_View (Parent_Type)) if Present (Full_View (Parent_Type))
and then not Is_Tagged_Type (Full_View (Parent_Type)) and then not Is_Tagged_Type (Full_View (Parent_Type))
and then not Is_Completion and then not Is_Completion
then then
Full_Der := Make_Defining_Identifier (Sloc (Derived_Type), Full_Der :=
Chars (Derived_Type)); Make_Defining_Identifier (Sloc (Derived_Type),
Chars => Chars (Derived_Type));
Set_Is_Itype (Full_Der); Set_Is_Itype (Full_Der);
Set_Has_Private_Declaration (Full_Der); Set_Has_Private_Declaration (Full_Der);
Set_Has_Private_Declaration (Derived_Type); Set_Has_Private_Declaration (Derived_Type);
...@@ -4483,7 +4469,7 @@ package body Sem_Ch3 is ...@@ -4483,7 +4469,7 @@ package body Sem_Ch3 is
-- Build_Derived_Record_Type -- -- Build_Derived_Record_Type --
------------------------------- -------------------------------
-- 1. INTRODUCTION. -- 1. INTRODUCTION
-- Ideally we would like to use the same model of type derivation for -- Ideally we would like to use the same model of type derivation for
-- tagged and untagged record types. Unfortunately this is not quite -- tagged and untagged record types. Unfortunately this is not quite
...@@ -4519,7 +4505,7 @@ package body Sem_Ch3 is ...@@ -4519,7 +4505,7 @@ package body Sem_Ch3 is
-- semantic rules are somewhat different). We will explain what differs -- semantic rules are somewhat different). We will explain what differs
-- below. -- below.
-- 2. DISCRIMINANTS UNDER INHERITANCE. -- 2. DISCRIMINANTS UNDER INHERITANCE
-- The semantic rules governing the discriminants of derived types are -- The semantic rules governing the discriminants of derived types are
-- quite subtle. -- quite subtle.
...@@ -4624,7 +4610,7 @@ package body Sem_Ch3 is ...@@ -4624,7 +4610,7 @@ package body Sem_Ch3 is
-- D2 in T3 empty itself yes -- D2 in T3 empty itself yes
-- D3 in T3 empty itself yes -- D3 in T3 empty itself yes
-- 4. DISCRIMINANTS IN DERIVED TAGGED RECORD TYPES. -- 4. DISCRIMINANTS IN DERIVED TAGGED RECORD TYPES
-- Type derivation for tagged types is fairly straightforward. if no -- Type derivation for tagged types is fairly straightforward. if no
-- discriminants are specified by the derived type, these are inherited -- discriminants are specified by the derived type, these are inherited
...@@ -4637,7 +4623,7 @@ package body Sem_Ch3 is ...@@ -4637,7 +4623,7 @@ package body Sem_Ch3 is
-- type T1 is new R with null record; -- type T1 is new R with null record;
-- type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with null record; -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with null record;
-- are changed into : -- are changed into:
-- type T1 (D1, D2, D3 : Int) is new R (D1, D2, D3) with record -- type T1 (D1, D2, D3 : Int) is new R (D1, D2, D3) with record
-- _parent : R (D1, D2, D3); -- _parent : R (D1, D2, D3);
...@@ -4663,7 +4649,7 @@ package body Sem_Ch3 is ...@@ -4663,7 +4649,7 @@ package body Sem_Ch3 is
-- X1 in T2 D3 in T1 D3 in R no -- X1 in T2 D3 in T1 D3 in R no
-- X2 in T2 D1 in T1 D1 in R no -- X2 in T2 D1 in T1 D1 in R no
-- 5. FIRST TRANSFORMATION FOR DERIVED RECORDS. -- 5. FIRST TRANSFORMATION FOR DERIVED RECORDS
-- --
-- Regardless of whether we dealing with a tagged or untagged type -- Regardless of whether we dealing with a tagged or untagged type
-- we will transform all derived type declarations of the form -- we will transform all derived type declarations of the form
...@@ -4752,7 +4738,7 @@ package body Sem_Ch3 is ...@@ -4752,7 +4738,7 @@ package body Sem_Ch3 is
-- above transformation will entail. This is done directly in routine -- above transformation will entail. This is done directly in routine
-- Inherit_Components. -- Inherit_Components.
-- 7. TYPE DERIVATION AND COMPONENT INHERITANCE. -- 7. TYPE DERIVATION AND COMPONENT INHERITANCE
-- In both tagged and untagged derived types, regular non discriminant -- In both tagged and untagged derived types, regular non discriminant
-- components are inherited in the derived type from the parent type. In -- components are inherited in the derived type from the parent type. In
...@@ -4785,7 +4771,7 @@ package body Sem_Ch3 is ...@@ -4785,7 +4771,7 @@ package body Sem_Ch3 is
-- For T2, for instance, this has the effect of replacing String (D1 .. D2) -- For T2, for instance, this has the effect of replacing String (D1 .. D2)
-- by String (1 .. X). -- by String (1 .. X).
-- 8. TYPE DERIVATION IN PRIVATE TYPE EXTENSIONS. -- 8. TYPE DERIVATION IN PRIVATE TYPE EXTENSIONS
-- We explain here the rules governing private type extensions relevant to -- We explain here the rules governing private type extensions relevant to
-- type derivation. These rules are explained on the following example: -- type derivation. These rules are explained on the following example:
...@@ -4851,7 +4837,7 @@ package body Sem_Ch3 is ...@@ -4851,7 +4837,7 @@ package body Sem_Ch3 is
-- P's constraints on A's discriminants must statically match those -- P's constraints on A's discriminants must statically match those
-- imposed by (...). -- imposed by (...).
-- 9. IMPLEMENTATION OF TYPE DERIVATION FOR PRIVATE EXTENSIONS. -- 9. IMPLEMENTATION OF TYPE DERIVATION FOR PRIVATE EXTENSIONS
-- The full view of a private extension is handled exactly as described -- The full view of a private extension is handled exactly as described
-- above. The model chose for the private view of a private extension -- above. The model chose for the private view of a private extension
...@@ -4908,7 +4894,7 @@ package body Sem_Ch3 is ...@@ -4908,7 +4894,7 @@ package body Sem_Ch3 is
-- ??? Are there are other uncomfortable cases that we will have to -- ??? Are there are other uncomfortable cases that we will have to
-- deal with. -- deal with.
-- 10. RECORD_TYPE_WITH_PRIVATE complications. -- 10. RECORD_TYPE_WITH_PRIVATE complications
-- Types that are derived from a visible record type and have a private -- Types that are derived from a visible record type and have a private
-- extension present other peculiarities. They behave mostly like private -- extension present other peculiarities. They behave mostly like private
...@@ -4928,20 +4914,18 @@ package body Sem_Ch3 is ...@@ -4928,20 +4914,18 @@ package body Sem_Ch3 is
is is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Parent_Base : Entity_Id; Parent_Base : Entity_Id;
Type_Def : Node_Id; Type_Def : Node_Id;
Indic : Node_Id; Indic : Node_Id;
Discrim : Entity_Id; Discrim : Entity_Id;
Last_Discrim : Entity_Id; Last_Discrim : Entity_Id;
Constrs : Elist_Id; Constrs : Elist_Id;
Discs : Elist_Id := New_Elmt_List; Discs : Elist_Id := New_Elmt_List;
-- An empty Discs list means that there were no constraints in the -- An empty Discs list means that there were no constraints in the
-- subtype indication or that there was an error processing it. -- subtype indication or that there was an error processing it.
Assoc_List : Elist_Id; Assoc_List : Elist_Id;
New_Discrs : Elist_Id; New_Discrs : Elist_Id;
New_Base : Entity_Id; New_Base : Entity_Id;
New_Decl : Node_Id; New_Decl : Node_Id;
New_Indic : Node_Id; New_Indic : Node_Id;
...@@ -4989,7 +4973,7 @@ package body Sem_Ch3 is ...@@ -4989,7 +4973,7 @@ package body Sem_Ch3 is
Init_Size_Align (Derived_Type); Init_Size_Align (Derived_Type);
end if; end if;
-- STEP 0a: figure out what kind of derived type declaration we have. -- STEP 0a: figure out what kind of derived type declaration we have
if Private_Extension then if Private_Extension then
Type_Def := N; Type_Def := N;
...@@ -5046,7 +5030,7 @@ package body Sem_Ch3 is ...@@ -5046,7 +5030,7 @@ package body Sem_Ch3 is
end if; end if;
end if; end if;
-- STEP 0b: If needed, apply transformation given in point 5. above. -- STEP 0b: If needed, apply transformation given in point 5. above
if not Private_Extension if not Private_Extension
and then Has_Discriminants (Parent_Type) and then Has_Discriminants (Parent_Type)
...@@ -5162,15 +5146,13 @@ package body Sem_Ch3 is ...@@ -5162,15 +5146,13 @@ package body Sem_Ch3 is
Analyze (N); Analyze (N);
-- Derivation of subprograms must be delayed until the -- Derivation of subprograms must be delayed until the full subtype
-- full subtype has been established to ensure proper -- has been established to ensure proper overriding of subprograms
-- overriding of subprograms inherited by full types. -- inherited by full types. If the derivations occurred as part of
-- If the derivations occurred as part of the call to -- the call to Build_Derived_Type above, then the check for type
-- Build_Derived_Type above, then the check for type -- conformance would fail because earlier primitive subprograms
-- conformance would fail because earlier primitive -- could still refer to the full type prior the change to the new
-- subprograms could still refer to the full type prior -- subtype and hence would not match the new base type created here.
-- the change to the new subtype and hence wouldn't
-- match the new base type created here.
Derive_Subprograms (Parent_Type, Derived_Type); Derive_Subprograms (Parent_Type, Derived_Type);
...@@ -5193,6 +5175,7 @@ package body Sem_Ch3 is ...@@ -5193,6 +5175,7 @@ package body Sem_Ch3 is
-- STEP 1a: perform preliminary actions/checks for derived tagged types -- STEP 1a: perform preliminary actions/checks for derived tagged types
if Is_Tagged then if Is_Tagged then
-- The parent type is frozen for non-private extensions (RM 13.14(7)) -- The parent type is frozen for non-private extensions (RM 13.14(7))
if not Private_Extension then if not Private_Extension then
...@@ -5238,7 +5221,7 @@ package body Sem_Ch3 is ...@@ -5238,7 +5221,7 @@ package body Sem_Ch3 is
-- conformance. However, we must remove any existing components that -- conformance. However, we must remove any existing components that
-- were inherited from the parent (and attached in Copy_And_Swap) -- were inherited from the parent (and attached in Copy_And_Swap)
-- because the full type inherits all appropriate components anyway, and -- because the full type inherits all appropriate components anyway, and
-- we don't want the partial view's components interfering. -- we do not want the partial view's components interfering.
if Has_Discriminants (Derived_Type) and then Discriminant_Specs then if Has_Discriminants (Derived_Type) and then Discriminant_Specs then
Discrim := First_Discriminant (Derived_Type); Discrim := First_Discriminant (Derived_Type);
...@@ -5269,7 +5252,7 @@ package body Sem_Ch3 is ...@@ -5269,7 +5252,7 @@ package body Sem_Ch3 is
Set_Is_Tagged_Type (Derived_Type, Is_Tagged); Set_Is_Tagged_Type (Derived_Type, Is_Tagged);
Set_Is_Limited_Record (Derived_Type, Is_Limited_Record (Parent_Type)); Set_Is_Limited_Record (Derived_Type, Is_Limited_Record (Parent_Type));
-- STEP 2a: process discriminants of derived type if any. -- STEP 2a: process discriminants of derived type if any
New_Scope (Derived_Type); New_Scope (Derived_Type);
...@@ -5314,7 +5297,6 @@ package body Sem_Ch3 is ...@@ -5314,7 +5297,6 @@ package body Sem_Ch3 is
-- discriminants cannot rename old ones (implied by [7.3(13)]). -- discriminants cannot rename old ones (implied by [7.3(13)]).
Discrim := First_Discriminant (Derived_Type); Discrim := First_Discriminant (Derived_Type);
while Present (Discrim) loop while Present (Discrim) loop
if not Is_Tagged if not Is_Tagged
and then not Present (Corresponding_Discriminant (Discrim)) and then not Present (Corresponding_Discriminant (Discrim))
...@@ -5539,8 +5521,8 @@ package body Sem_Ch3 is ...@@ -5539,8 +5521,8 @@ package body Sem_Ch3 is
if not Is_Tagged then if not Is_Tagged then
-- Discriminant_Constraint (Derived_Type) has been properly -- Discriminant_Constraint (Derived_Type) has been properly
-- constructed. Save it and temporarily set it to Empty because we do -- constructed. Save it and temporarily set it to Empty because we
-- not want the call to New_Copy_Tree below to mess this list. -- do not want the call to New_Copy_Tree below to mess this list.
if Has_Discriminants (Derived_Type) then if Has_Discriminants (Derived_Type) then
Save_Discr_Constr := Discriminant_Constraint (Derived_Type); Save_Discr_Constr := Discriminant_Constraint (Derived_Type);
...@@ -5549,9 +5531,9 @@ package body Sem_Ch3 is ...@@ -5549,9 +5531,9 @@ package body Sem_Ch3 is
Save_Discr_Constr := No_Elist; Save_Discr_Constr := No_Elist;
end if; end if;
-- Save the Etype field of Derived_Type. It is correctly set now, but -- Save the Etype field of Derived_Type. It is correctly set now,
-- the call to New_Copy tree may remap it to point to itself, which -- but the call to New_Copy tree may remap it to point to itself,
-- is not what we want. Ditto for the Next_Entity field. -- which is not what we want. Ditto for the Next_Entity field.
Save_Etype := Etype (Derived_Type); Save_Etype := Etype (Derived_Type);
Save_Next_Entity := Next_Entity (Derived_Type); Save_Next_Entity := Next_Entity (Derived_Type);
...@@ -5560,7 +5542,7 @@ package body Sem_Ch3 is ...@@ -5560,7 +5542,7 @@ package body Sem_Ch3 is
-- stored discriminants in the Derived_Type. It is fundamental that -- stored discriminants in the Derived_Type. It is fundamental that
-- no types or itypes with discriminants other than the stored -- no types or itypes with discriminants other than the stored
-- discriminants appear in the entities declared inside -- discriminants appear in the entities declared inside
-- Derived_Type. Gigi won't like it. -- Derived_Type, since the back end cannot deal with it.
New_Decl := New_Decl :=
New_Copy_Tree New_Copy_Tree
...@@ -5640,6 +5622,16 @@ package body Sem_Ch3 is ...@@ -5640,6 +5622,16 @@ package body Sem_Ch3 is
end if; end if;
end if; end if;
-- Update the class_wide type, which shares the now-completed
-- entity list with its specific type.
if Is_Tagged then
Set_First_Entity
(Class_Wide_Type (Derived_Type), First_Entity (Derived_Type));
Set_Last_Entity
(Class_Wide_Type (Derived_Type), Last_Entity (Derived_Type));
end if;
end Build_Derived_Record_Type; end Build_Derived_Record_Type;
------------------------ ------------------------
...@@ -5775,9 +5767,11 @@ package body Sem_Ch3 is ...@@ -5775,9 +5767,11 @@ package body Sem_Ch3 is
CR_Disc : Entity_Id; CR_Disc : Entity_Id;
begin begin
-- A discriminal has the same names as the discriminant. -- A discriminal has the same name as the discriminant
D_Minal := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim)); D_Minal :=
Make_Defining_Identifier (Sloc (Discrim),
Chars => Chars (Discrim));
Set_Ekind (D_Minal, E_In_Parameter); Set_Ekind (D_Minal, E_In_Parameter);
Set_Mechanism (D_Minal, Default_Mechanism); Set_Mechanism (D_Minal, Default_Mechanism);
...@@ -5813,8 +5807,9 @@ package body Sem_Ch3 is ...@@ -5813,8 +5807,9 @@ package body Sem_Ch3 is
is is
C : constant Node_Id := Constraint (Def); C : constant Node_Id := Constraint (Def);
Nb_Discr : constant Nat := Number_Discriminants (T); Nb_Discr : constant Nat := Number_Discriminants (T);
Discr_Expr : array (1 .. Nb_Discr) of Node_Id := (others => Empty); Discr_Expr : array (1 .. Nb_Discr) of Node_Id := (others => Empty);
-- Saves the expression corresponding to a given discriminant in T. -- Saves the expression corresponding to a given discriminant in T
function Pos_Of_Discr (T : Entity_Id; D : Entity_Id) return Nat; function Pos_Of_Discr (T : Entity_Id; D : Entity_Id) return Nat;
-- Return the Position number within array Discr_Expr of a discriminant -- Return the Position number within array Discr_Expr of a discriminant
...@@ -6744,7 +6739,6 @@ package body Sem_Ch3 is ...@@ -6744,7 +6739,6 @@ package body Sem_Ch3 is
Rewrite (E, Rewrite (E,
Make_Real_Literal (Sloc (E), Ureal_Tenth)); Make_Real_Literal (Sloc (E), Ureal_Tenth));
Analyze_And_Resolve (E, Standard_Float); Analyze_And_Resolve (E, Standard_Float);
end Check_Delta_Expression; end Check_Delta_Expression;
----------------------------- -----------------------------
...@@ -6905,7 +6899,6 @@ package body Sem_Ch3 is ...@@ -6905,7 +6899,6 @@ package body Sem_Ch3 is
Save_Homonym := Homonym (Priv); Save_Homonym := Homonym (Priv);
case Ekind (Full_Base) is case Ekind (Full_Base) is
when E_Record_Type | when E_Record_Type |
E_Record_Subtype | E_Record_Subtype |
Class_Wide_Kind | Class_Wide_Kind |
...@@ -6923,14 +6916,13 @@ package body Sem_Ch3 is ...@@ -6923,14 +6916,13 @@ package body Sem_Ch3 is
Set_Chars (Full, Chars (Priv)); Set_Chars (Full, Chars (Priv));
Conditional_Delay (Full, Priv); Conditional_Delay (Full, Priv);
Set_Sloc (Full, Sloc (Priv)); Set_Sloc (Full, Sloc (Priv));
end case; end case;
Set_Next_Entity (Full, Save_Next_Entity); Set_Next_Entity (Full, Save_Next_Entity);
Set_Homonym (Full, Save_Homonym); Set_Homonym (Full, Save_Homonym);
Set_Associated_Node_For_Itype (Full, Related_Nod); Set_Associated_Node_For_Itype (Full, Related_Nod);
-- Set common attributes for all subtypes. -- Set common attributes for all subtypes
Set_Ekind (Full, Subtype_Kind (Ekind (Full_Base))); Set_Ekind (Full, Subtype_Kind (Ekind (Full_Base)));
...@@ -6944,7 +6936,7 @@ package body Sem_Ch3 is ...@@ -6944,7 +6936,7 @@ package body Sem_Ch3 is
-- Set_Etype (Full, Full_Base); -- Set_Etype (Full, Full_Base);
-- then we get inconsistencies in the front-end (confusion between -- then we get inconsistencies in the front-end (confusion between
-- views). Several outstanding bugs are related to this. -- views). Several outstanding bugs are related to this ???
Set_Is_First_Subtype (Full, False); Set_Is_First_Subtype (Full, False);
Set_Scope (Full, Scope (Priv)); Set_Scope (Full, Scope (Priv));
...@@ -6991,6 +6983,7 @@ package body Sem_Ch3 is ...@@ -6991,6 +6983,7 @@ package body Sem_Ch3 is
if Has_Discriminants (Full) then if Has_Discriminants (Full) then
Set_Stored_Constraint_From_Discriminant_Constraint (Full); Set_Stored_Constraint_From_Discriminant_Constraint (Full);
Set_Stored_Constraint (Priv, Stored_Constraint (Full)); Set_Stored_Constraint (Priv, Stored_Constraint (Full));
if Has_Unknown_Discriminants (Full) then if Has_Unknown_Discriminants (Full) then
Set_Discriminant_Constraint (Full, No_Elist); Set_Discriminant_Constraint (Full, No_Elist);
end if; end if;
...@@ -7029,7 +7022,7 @@ package body Sem_Ch3 is ...@@ -7029,7 +7022,7 @@ package body Sem_Ch3 is
elsif Is_Record_Type (Full_Base) then elsif Is_Record_Type (Full_Base) then
-- Show Full is simply a renaming of Full_Base. -- Show Full is simply a renaming of Full_Base
Set_Cloned_Subtype (Full, Full_Base); Set_Cloned_Subtype (Full, Full_Base);
end if; end if;
...@@ -7080,7 +7073,6 @@ package body Sem_Ch3 is ...@@ -7080,7 +7073,6 @@ package body Sem_Ch3 is
Corresponding_Record_Type (Full_Base)); Corresponding_Record_Type (Full_Base));
end if; end if;
end if; end if;
end Complete_Private_Subtype; end Complete_Private_Subtype;
---------------------------- ----------------------------
...@@ -7113,7 +7105,6 @@ package body Sem_Ch3 is ...@@ -7113,7 +7105,6 @@ package body Sem_Ch3 is
begin begin
if Is_Record_Type (Typ) then if Is_Record_Type (Typ) then
Comp := First_Component (Typ); Comp := First_Component (Typ);
while Present (Comp) loop while Present (Comp) loop
if Comes_From_Source (Comp) then if Comes_From_Source (Comp) then
if Present (Expression (Parent (Comp))) if Present (Expression (Parent (Comp)))
...@@ -7167,7 +7158,7 @@ package body Sem_Ch3 is ...@@ -7167,7 +7158,7 @@ package body Sem_Ch3 is
end if; end if;
else else
-- Current declaration is illegal, diagnosed below in Enter_Name. -- Current declaration is illegal, diagnosed below in Enter_Name
T := Empty; T := Empty;
New_T := Any_Type; New_T := Any_Type;
...@@ -7183,7 +7174,7 @@ package body Sem_Ch3 is ...@@ -7183,7 +7174,7 @@ package body Sem_Ch3 is
then then
Enter_Name (Id); Enter_Name (Id);
-- Verify that types of both declarations match. -- Verify that types of both declarations match
elsif Base_Type (Etype (Prev)) /= Base_Type (New_T) then elsif Base_Type (Etype (Prev)) /= Base_Type (New_T) then
Error_Msg_Sloc := Sloc (Prev); Error_Msg_Sloc := Sloc (Prev);
...@@ -7258,12 +7249,11 @@ package body Sem_Ch3 is ...@@ -7258,12 +7249,11 @@ package body Sem_Ch3 is
or else Is_Incomplete_Or_Private_Type (Desig_Type)) or else Is_Incomplete_Or_Private_Type (Desig_Type))
and then not Is_Constrained (Desig_Type) and then not Is_Constrained (Desig_Type)
then then
-- ??? The following code is a temporary kludge to ignore -- ??? The following code is a temporary kludge to ignore a
-- discriminant constraint on access type if -- discriminant constraint on access type if it is constraining
-- it is constraining the current record. Avoid creating the -- the current record. Avoid creating the implicit subtype of the
-- implicit subtype of the record we are currently compiling -- record we are currently compiling since right now, we cannot
-- since right now, we cannot handle these. -- handle these. For now, just return the access type itself.
-- For now, just return the access type itself.
if Desig_Type = Current_Scope if Desig_Type = Current_Scope
and then No (Def_Id) and then No (Def_Id)
...@@ -7271,14 +7261,12 @@ package body Sem_Ch3 is ...@@ -7271,14 +7261,12 @@ package body Sem_Ch3 is
Set_Ekind (Desig_Subtype, E_Record_Subtype); Set_Ekind (Desig_Subtype, E_Record_Subtype);
Def_Id := Entity (Subtype_Mark (S)); Def_Id := Entity (Subtype_Mark (S));
-- This call added to ensure that the constraint is -- This call added to ensure that the constraint is analyzed
-- analyzed (needed for a B test). Note that we -- (needed for a B test). Note that we still return early from
-- still return early from this procedure to avoid -- this procedure to avoid recursive processing. ???
-- recursive processing. ???
Constrain_Discriminated_Type Constrain_Discriminated_Type
(Desig_Subtype, S, Related_Nod, For_Access => True); (Desig_Subtype, S, Related_Nod, For_Access => True);
return; return;
end if; end if;
...@@ -7303,7 +7291,6 @@ package body Sem_Ch3 is ...@@ -7303,7 +7291,6 @@ package body Sem_Ch3 is
if Nkind (Pack) = N_Package_Declaration then if Nkind (Pack) = N_Package_Declaration then
Decls := Visible_Declarations (Specification (Pack)); Decls := Visible_Declarations (Specification (Pack));
Decl := First (Decls); Decl := First (Decls);
while Present (Decl) loop while Present (Decl) loop
if (Nkind (Decl) = N_Private_Type_Declaration if (Nkind (Decl) = N_Private_Type_Declaration
and then and then
...@@ -7507,7 +7494,7 @@ package body Sem_Ch3 is ...@@ -7507,7 +7494,7 @@ package body Sem_Ch3 is
function Build_Constrained_Discriminated_Type function Build_Constrained_Discriminated_Type
(Old_Type : Entity_Id) return Entity_Id; (Old_Type : Entity_Id) return Entity_Id;
-- Ditto for record components. -- Ditto for record components
function Build_Constrained_Access_Type function Build_Constrained_Access_Type
(Old_Type : Entity_Id) return Entity_Id; (Old_Type : Entity_Id) return Entity_Id;
...@@ -7519,10 +7506,10 @@ package body Sem_Ch3 is ...@@ -7519,10 +7506,10 @@ package body Sem_Ch3 is
-- that apply to T. This routine builds the constrained subtype. -- that apply to T. This routine builds the constrained subtype.
function Is_Discriminant (Expr : Node_Id) return Boolean; function Is_Discriminant (Expr : Node_Id) return Boolean;
-- Returns True if Expr is a discriminant. -- Returns True if Expr is a discriminant
function Get_Discr_Value (Discrim : Entity_Id) return Node_Id; function Get_Discr_Value (Discrim : Entity_Id) return Node_Id;
-- Find the value of discriminant Discrim in Constraint. -- Find the value of discriminant Discrim in Constraint
----------------------------------- -----------------------------------
-- Build_Constrained_Access_Type -- -- Build_Constrained_Access_Type --
...@@ -7579,6 +7566,7 @@ package body Sem_Ch3 is ...@@ -7579,6 +7566,7 @@ package body Sem_Ch3 is
end if; end if;
if Desig_Subtype /= Desig_Type then if Desig_Subtype /= Desig_Type then
-- The Related_Node better be here or else we won't be able -- The Related_Node better be here or else we won't be able
-- to attach new itypes to a node in the tree. -- to attach new itypes to a node in the tree.
...@@ -7947,8 +7935,8 @@ package body Sem_Ch3 is ...@@ -7947,8 +7935,8 @@ package body Sem_Ch3 is
Related_Nod : Node_Id; Related_Nod : Node_Id;
Related_Id : Entity_Id) return Entity_Id Related_Id : Entity_Id) return Entity_Id
is is
T_Sub : constant Entity_Id T_Sub : constant Entity_Id :=
:= Create_Itype (E_Record_Subtype, Related_Nod, Related_Id, 'V'); Create_Itype (E_Record_Subtype, Related_Nod, Related_Id, 'V');
begin begin
Set_Etype (T_Sub, Corr_Rec); Set_Etype (T_Sub, Corr_Rec);
...@@ -7961,11 +7949,11 @@ package body Sem_Ch3 is ...@@ -7961,11 +7949,11 @@ package body Sem_Ch3 is
Conditional_Delay (T_Sub, Corr_Rec); Conditional_Delay (T_Sub, Corr_Rec);
if Has_Discriminants (Prot_Subt) then -- False only if errors. if Has_Discriminants (Prot_Subt) then -- False only if errors.
Set_Discriminant_Constraint (T_Sub, Set_Discriminant_Constraint
Discriminant_Constraint (Prot_Subt)); (T_Sub, Discriminant_Constraint (Prot_Subt));
Set_Stored_Constraint_From_Discriminant_Constraint (T_Sub); Set_Stored_Constraint_From_Discriminant_Constraint (T_Sub);
Create_Constrained_Components (T_Sub, Related_Nod, Corr_Rec, Create_Constrained_Components
Discriminant_Constraint (T_Sub)); (T_Sub, Related_Nod, Corr_Rec, Discriminant_Constraint (T_Sub));
end if; end if;
Set_Depends_On_Private (T_Sub, Has_Private_Component (T_Sub)); Set_Depends_On_Private (T_Sub, Has_Private_Component (T_Sub));
...@@ -8033,7 +8021,6 @@ package body Sem_Ch3 is ...@@ -8033,7 +8021,6 @@ package body Sem_Ch3 is
Convert_To (T, Make_Real_Literal (Loc, (-Bound_Val))), Convert_To (T, Make_Real_Literal (Loc, (-Bound_Val))),
High_Bound => High_Bound =>
Convert_To (T, Make_Real_Literal (Loc, Bound_Val))); Convert_To (T, Make_Real_Literal (Loc, Bound_Val)));
end if; end if;
Set_Scalar_Range_For_Subtype (Def_Id, Range_Expr, T); Set_Scalar_Range_For_Subtype (Def_Id, Range_Expr, T);
...@@ -8164,7 +8151,6 @@ package body Sem_Ch3 is ...@@ -8164,7 +8151,6 @@ package body Sem_Ch3 is
Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
Set_Discrete_RM_Size (Def_Id); Set_Discrete_RM_Size (Def_Id);
end Constrain_Enumeration; end Constrain_Enumeration;
---------------------- ----------------------
...@@ -8283,14 +8269,15 @@ package body Sem_Ch3 is ...@@ -8283,14 +8269,15 @@ package body Sem_Ch3 is
end if; end if;
elsif Nkind (S) = N_Subtype_Indication then elsif Nkind (S) = N_Subtype_Indication then
-- the parser has verified that this is a discrete indication.
-- The parser has verified that this is a discrete indication
Resolve_Discrete_Subtype_Indication (S, T); Resolve_Discrete_Subtype_Indication (S, T);
R := Range_Expression (Constraint (S)); R := Range_Expression (Constraint (S));
elsif Nkind (S) = N_Discriminant_Association then elsif Nkind (S) = N_Discriminant_Association then
-- syntactically valid in subtype indication. -- Syntactically valid in subtype indication
Error_Msg_N ("invalid index constraint", S); Error_Msg_N ("invalid index constraint", S);
Rewrite (S, New_Occurrence_Of (T, Sloc (S))); Rewrite (S, New_Occurrence_Of (T, Sloc (S)));
...@@ -8302,7 +8289,6 @@ package body Sem_Ch3 is ...@@ -8302,7 +8289,6 @@ package body Sem_Ch3 is
Analyze (S); Analyze (S);
if Is_Entity_Name (S) then if Is_Entity_Name (S) then
if not Is_Type (Entity (S)) then if not Is_Type (Entity (S)) then
Error_Msg_N ("expect subtype mark for index constraint", S); Error_Msg_N ("expect subtype mark for index constraint", S);
...@@ -8366,7 +8352,6 @@ package body Sem_Ch3 is ...@@ -8366,7 +8352,6 @@ package body Sem_Ch3 is
Set_Size_Info (Def_Id, (T)); Set_Size_Info (Def_Id, (T));
Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
Set_Discrete_RM_Size (Def_Id); Set_Discrete_RM_Size (Def_Id);
end Constrain_Integer; end Constrain_Integer;
------------------------------ ------------------------------
...@@ -8514,7 +8499,6 @@ package body Sem_Ch3 is ...@@ -8514,7 +8499,6 @@ package body Sem_Ch3 is
------------------- -------------------
procedure Copy_And_Swap (Priv, Full : Entity_Id) is procedure Copy_And_Swap (Priv, Full : Entity_Id) is
begin begin
-- Initialize new full declaration entity by copying the pertinent -- Initialize new full declaration entity by copying the pertinent
-- fields of the corresponding private declaration entity. -- fields of the corresponding private declaration entity.
...@@ -8674,7 +8658,6 @@ package body Sem_Ch3 is ...@@ -8674,7 +8658,6 @@ package body Sem_Ch3 is
Old_C := First_Discriminant (Typ); Old_C := First_Discriminant (Typ);
Discr_Val := First_Elmt (Constraints); Discr_Val := First_Elmt (Constraints);
while Present (Old_C) loop while Present (Old_C) loop
Append_To (Assoc_List, Append_To (Assoc_List,
Make_Component_Association (Loc, Make_Component_Association (Loc,
...@@ -8692,7 +8675,6 @@ package body Sem_Ch3 is ...@@ -8692,7 +8675,6 @@ package body Sem_Ch3 is
or else Has_Controlled_Component (Typ) or else Has_Controlled_Component (Typ)
then then
Old_C := First_Component (Typ); Old_C := First_Component (Typ);
while Present (Old_C) loop while Present (Old_C) loop
if Chars ((Old_C)) = Name_uTag if Chars ((Old_C)) = Name_uTag
or else Chars ((Old_C)) = Name_uParent or else Chars ((Old_C)) = Name_uParent
...@@ -8715,7 +8697,6 @@ package body Sem_Ch3 is ...@@ -8715,7 +8697,6 @@ package body Sem_Ch3 is
begin begin
Comp := First_Elmt (Comp_List); Comp := First_Elmt (Comp_List);
while Present (Comp) loop while Present (Comp) loop
Old_C := Node (Comp); Old_C := Node (Comp);
New_C := Create_Component (Old_C); New_C := Create_Component (Old_C);
...@@ -8785,9 +8766,7 @@ package body Sem_Ch3 is ...@@ -8785,9 +8766,7 @@ package body Sem_Ch3 is
-- optimize the list of components. -- optimize the list of components.
Discr_Val := First_Elmt (Constraints); Discr_Val := First_Elmt (Constraints);
while Present (Discr_Val) loop while Present (Discr_Val) loop
if not Is_OK_Static_Expression (Node (Discr_Val)) then if not Is_OK_Static_Expression (Node (Discr_Val)) then
Is_Static := False; Is_Static := False;
exit; exit;
...@@ -8798,10 +8777,9 @@ package body Sem_Ch3 is ...@@ -8798,10 +8777,9 @@ package body Sem_Ch3 is
New_Scope (Subt); New_Scope (Subt);
-- Inherit the discriminants of the parent type. -- Inherit the discriminants of the parent type
Old_C := First_Discriminant (Typ); Old_C := First_Discriminant (Typ);
while Present (Old_C) loop while Present (Old_C) loop
New_C := Create_Component (Old_C); New_C := Create_Component (Old_C);
Set_Is_Public (New_C, Is_Public (Subt)); Set_Is_Public (New_C, Is_Public (Subt));
...@@ -8851,7 +8829,6 @@ package body Sem_Ch3 is ...@@ -8851,7 +8829,6 @@ package body Sem_Ch3 is
(Record_Extension_Part (Type_Definition (Parent (Typ)))) (Record_Extension_Part (Type_Definition (Parent (Typ))))
then then
Old_C := First_Component (Typ); Old_C := First_Component (Typ);
while Present (Old_C) loop while Present (Old_C) loop
if Original_Record_Component (Old_C) = Old_C if Original_Record_Component (Old_C) = Old_C
and then Chars (Old_C) /= Name_uTag and then Chars (Old_C) /= Name_uTag
...@@ -8873,7 +8850,6 @@ package body Sem_Ch3 is ...@@ -8873,7 +8850,6 @@ package body Sem_Ch3 is
-- parent type. -- parent type.
Old_C := First_Component (Typ); Old_C := First_Component (Typ);
while Present (Old_C) loop while Present (Old_C) loop
New_C := Create_Component (Old_C); New_C := Create_Component (Old_C);
...@@ -9093,12 +9069,11 @@ package body Sem_Ch3 is ...@@ -9093,12 +9069,11 @@ package body Sem_Ch3 is
Prev : Entity_Id; Prev : Entity_Id;
begin begin
Prev := Homonym (Parent_Subp);
-- The visible operation that is overriden is a homonym of -- The visible operation that is overriden is a homonym of
-- the parent subprogram. We scan the homonym chain to find -- the parent subprogram. We scan the homonym chain to find
-- the one whose alias is the subprogram we are deriving. -- the one whose alias is the subprogram we are deriving.
Prev := Homonym (Parent_Subp);
while Present (Prev) loop while Present (Prev) loop
if Is_Dispatching_Operation (Parent_Subp) if Is_Dispatching_Operation (Parent_Subp)
and then Present (Prev) and then Present (Prev)
...@@ -9150,7 +9125,7 @@ package body Sem_Ch3 is ...@@ -9150,7 +9125,7 @@ package body Sem_Ch3 is
Set_Etype (Acc_Type, Acc_Type); Set_Etype (Acc_Type, Acc_Type);
Set_Scope (Acc_Type, New_Subp); Set_Scope (Acc_Type, New_Subp);
-- Compute size of anonymous access type. -- Compute size of anonymous access type
if Is_Array_Type (Desig_Typ) if Is_Array_Type (Desig_Typ)
and then not Is_Constrained (Desig_Typ) and then not Is_Constrained (Desig_Typ)
...@@ -9161,7 +9136,6 @@ package body Sem_Ch3 is ...@@ -9161,7 +9136,6 @@ package body Sem_Ch3 is
end if; end if;
Init_Alignment (Acc_Type); Init_Alignment (Acc_Type);
Set_Directly_Designated_Type (Acc_Type, Derived_Type); Set_Directly_Designated_Type (Acc_Type, Derived_Type);
Set_Etype (New_Id, Acc_Type); Set_Etype (New_Id, Acc_Type);
...@@ -9459,8 +9433,6 @@ package body Sem_Ch3 is ...@@ -9459,8 +9433,6 @@ package body Sem_Ch3 is
Parent_Base := Parent_Type; Parent_Base := Parent_Type;
end if; end if;
Elmt := First_Elmt (Op_List);
if Present (Generic_Actual) then if Present (Generic_Actual) then
Act_List := Collect_Primitive_Operations (Generic_Actual); Act_List := Collect_Primitive_Operations (Generic_Actual);
Act_Elmt := First_Elmt (Act_List); Act_Elmt := First_Elmt (Act_List);
...@@ -9471,6 +9443,7 @@ package body Sem_Ch3 is ...@@ -9471,6 +9443,7 @@ package body Sem_Ch3 is
-- Literals are derived earlier in the process of building the -- Literals are derived earlier in the process of building the
-- derived type, and are skipped here. -- derived type, and are skipped here.
Elmt := First_Elmt (Op_List);
while Present (Elmt) loop while Present (Elmt) loop
Subp := Node (Elmt); Subp := Node (Elmt);
...@@ -9727,6 +9700,7 @@ package body Sem_Ch3 is ...@@ -9727,6 +9700,7 @@ package body Sem_Ch3 is
("type derived from untagged type cannot have extension", Indic); ("type derived from untagged type cannot have extension", Indic);
elsif No (Extension) and then Taggd then elsif No (Extension) and then Taggd then
-- If this is within a private part (or body) of a generic -- If this is within a private part (or body) of a generic
-- instantiation then the derivation is allowed (the parent -- instantiation then the derivation is allowed (the parent
-- type can only appear tagged in this case if it's a generic -- type can only appear tagged in this case if it's a generic
...@@ -9892,14 +9866,11 @@ package body Sem_Ch3 is ...@@ -9892,14 +9866,11 @@ package body Sem_Ch3 is
Discriminant := Discriminant :=
First_Stored_Discriminant (Explicitly_Discriminated_Type); First_Stored_Discriminant (Explicitly_Discriminated_Type);
while Present (Discriminant) loop while Present (Discriminant) loop
Append_Elmt ( Append_Elmt (
Get_Discriminant_Value ( Get_Discriminant_Value (
Discriminant, Explicitly_Discriminated_Type, Constraint), Discriminant, Explicitly_Discriminated_Type, Constraint),
Expansion); Expansion);
Next_Stored_Discriminant (Discriminant); Next_Stored_Discriminant (Discriminant);
end loop; end loop;
...@@ -9917,7 +9888,7 @@ package body Sem_Ch3 is ...@@ -9917,7 +9888,7 @@ package body Sem_Ch3 is
Prev_Par : Node_Id; Prev_Par : Node_Id;
begin begin
-- Find incomplete declaration, if some was given. -- Find incomplete declaration, if one was given
Prev := Current_Entity_In_Scope (Id); Prev := Current_Entity_In_Scope (Id);
...@@ -9991,14 +9962,14 @@ package body Sem_Ch3 is ...@@ -9991,14 +9962,14 @@ package body Sem_Ch3 is
elsif Nkind (N) /= N_Full_Type_Declaration elsif Nkind (N) /= N_Full_Type_Declaration
or else Nkind (Type_Definition (N)) /= N_Derived_Type_Definition or else Nkind (Type_Definition (N)) /= N_Derived_Type_Definition
then then
Error_Msg_N ("full view of private extension must be" Error_Msg_N
& " an extension", N); ("full view of private extension must be an extension", N);
elsif not (Abstract_Present (Parent (Prev))) elsif not (Abstract_Present (Parent (Prev)))
and then Abstract_Present (Type_Definition (N)) and then Abstract_Present (Type_Definition (N))
then then
Error_Msg_N ("full view of non-abstract extension cannot" Error_Msg_N
& " be abstract", N); ("full view of non-abstract extension cannot be abstract", N);
end if; end if;
if not In_Private_Part (Current_Scope) then if not In_Private_Part (Current_Scope) then
...@@ -10050,10 +10021,9 @@ package body Sem_Ch3 is ...@@ -10050,10 +10021,9 @@ package body Sem_Ch3 is
end if; end if;
end if; end if;
-- A prior untagged private type can have an associated -- A prior untagged private type can have an associated class-wide
-- class-wide type due to use of the class attribute, -- type due to use of the class attribute, and in this case also the
-- and in this case also the full type is required to -- full type is required to be tagged.
-- be tagged.
if Is_Type (Prev) if Is_Type (Prev)
and then (Is_Tagged_Type (Prev) and then (Is_Tagged_Type (Prev)
...@@ -10355,7 +10325,6 @@ package body Sem_Ch3 is ...@@ -10355,7 +10325,6 @@ package body Sem_Ch3 is
Set_RM_Size (T, RM_Size (Implicit_Base)); Set_RM_Size (T, RM_Size (Implicit_Base));
Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base)); Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
Set_Digits_Value (T, Digs_Val); Set_Digits_Value (T, Digs_Val);
end Floating_Point_Type_Declaration; end Floating_Point_Type_Declaration;
---------------------------- ----------------------------
...@@ -10389,9 +10358,9 @@ package body Sem_Ch3 is ...@@ -10389,9 +10358,9 @@ package body Sem_Ch3 is
-- Typ_For_Constraint has discriminants, and the value for each -- Typ_For_Constraint has discriminants, and the value for each
-- discriminant is given by its corresponding Elmt of Constraints. -- discriminant is given by its corresponding Elmt of Constraints.
-- Discriminant is some discriminant in this hierarchy. -- Discriminant is some discriminant in this hierarchy
-- We need to return its value. -- We need to return its value
-- We do this by recursively searching each level, and looking for -- We do this by recursively searching each level, and looking for
-- Discriminant. Once we get to the bottom, we start backing up -- Discriminant. Once we get to the bottom, we start backing up
...@@ -10493,13 +10462,11 @@ package body Sem_Ch3 is ...@@ -10493,13 +10462,11 @@ package body Sem_Ch3 is
end if; end if;
end if; end if;
-- If Result is not a (reference to a) discriminant, -- If Result is not a (reference to a) discriminant, return it,
-- return it, otherwise set Result_Entity to the discriminant. -- otherwise set Result_Entity to the discriminant.
if Nkind (Result) = N_Defining_Identifier then if Nkind (Result) = N_Defining_Identifier then
pragma Assert (Result = Discriminant); pragma Assert (Result = Discriminant);
Result_Entity := Result; Result_Entity := Result;
else else
...@@ -10532,7 +10499,6 @@ package body Sem_Ch3 is ...@@ -10532,7 +10499,6 @@ package body Sem_Ch3 is
end if; end if;
while Present (Disc) loop while Present (Disc) loop
pragma Assert (Present (Assoc)); pragma Assert (Present (Assoc));
if Original_Record_Component (Disc) = Result_Entity then if Original_Record_Component (Disc) = Result_Entity then
...@@ -10558,14 +10524,14 @@ package body Sem_Ch3 is ...@@ -10558,14 +10524,14 @@ package body Sem_Ch3 is
-- Start of processing for Get_Discriminant_Value -- Start of processing for Get_Discriminant_Value
begin begin
-- ??? this routine is a gigantic mess and will be deleted. -- ??? This routine is a gigantic mess and will be deleted. For the
-- for the time being just test for the trivial case before calling -- time being just test for the trivial case before calling recurse.
-- recurse.
if Base_Type (Scope (Discriminant)) = Base_Type (Typ_For_Constraint) then if Base_Type (Scope (Discriminant)) = Base_Type (Typ_For_Constraint) then
declare declare
D : Entity_Id := First_Discriminant (Typ_For_Constraint); D : Entity_Id := First_Discriminant (Typ_For_Constraint);
E : Elmt_Id := First_Elmt (Constraint); E : Elmt_Id := First_Elmt (Constraint);
begin begin
while Present (D) loop while Present (D) loop
if Chars (D) = Chars (Discriminant) then if Chars (D) = Chars (Discriminant) then
...@@ -10757,14 +10723,13 @@ package body Sem_Ch3 is ...@@ -10757,14 +10723,13 @@ package body Sem_Ch3 is
end if; end if;
end Inherit_Component; end Inherit_Component;
-- Variables local to Inherit_Components. -- Variables local to Inherit_Component
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Parent_Discrim : Entity_Id; Parent_Discrim : Entity_Id;
Stored_Discrim : Entity_Id; Stored_Discrim : Entity_Id;
D : Entity_Id; D : Entity_Id;
Component : Entity_Id; Component : Entity_Id;
-- Start of processing for Inherit_Components -- Start of processing for Inherit_Components
...@@ -10886,7 +10851,6 @@ package body Sem_Ch3 is ...@@ -10886,7 +10851,6 @@ package body Sem_Ch3 is
is is
begin begin
case T_Kind is case T_Kind is
when Enumeration_Kind | when Enumeration_Kind |
Integer_Kind => Integer_Kind =>
return Constraint_Kind = N_Range_Constraint; return Constraint_Kind = N_Range_Constraint;
...@@ -10920,9 +10884,8 @@ package body Sem_Ch3 is ...@@ -10920,9 +10884,8 @@ package body Sem_Ch3 is
return Constraint_Kind = N_Index_Or_Discriminant_Constraint; return Constraint_Kind = N_Index_Or_Discriminant_Constraint;
when others => when others =>
return True; -- Error will be detected later. return True; -- Error will be detected later
end case; end case;
end Is_Valid_Constraint_Kind; end Is_Valid_Constraint_Kind;
-------------------------- --------------------------
...@@ -10956,6 +10919,7 @@ package body Sem_Ch3 is ...@@ -10956,6 +10919,7 @@ package body Sem_Ch3 is
Scop := Scope (Scop); Scop := Scope (Scop);
end loop; end loop;
return False; return False;
end Is_Local_Type; end Is_Local_Type;
...@@ -10996,28 +10960,26 @@ package body Sem_Ch3 is ...@@ -10996,28 +10960,26 @@ package body Sem_Ch3 is
elsif In_Instance_Body then elsif In_Instance_Body then
return True; return True;
-- Discriminants are always visible. -- Discriminants are always visible
elsif Ekind (Original_Comp) = E_Discriminant elsif Ekind (Original_Comp) = E_Discriminant
and then not Has_Unknown_Discriminants (Original_Scope) and then not Has_Unknown_Discriminants (Original_Scope)
then then
return True; return True;
-- If the component has been declared in an ancestor which is -- If the component has been declared in an ancestor which is currently
-- currently a private type, then it is not visible. The same -- a private type, then it is not visible. The same applies if the
-- applies if the component's containing type is not in an -- component's containing type is not in an open scope and the original
-- open scope and the original component's enclosing type -- component's enclosing type is a visible full type of a private type
-- is a visible full type of a private type (which can occur -- (which can occur in cases where an attempt is being made to reference
-- in cases where an attempt is being made to reference a -- a component in a sibling package that is inherited from a visible
-- component in a sibling package that is inherited from a -- component of a type in an ancestor package; the component in the
-- visible component of a type in an ancestor package; the -- sibling package should not be visible even though the component it
-- component in the sibling package should not be visible -- inherited from is visible). This does not apply however in the case
-- even though the component it inherited from is visible). -- where the scope of the type is a private child unit, or when the
-- This does not apply however in the case where the scope -- parent comes from a local package in which the ancestor is currently
-- of the type is a private child unit, or when the parent -- visible. The latter suppression of visibility is needed for cases
-- comes from a local package in which the ancestor is -- that are tested in B730006.
-- currently visible. The latter suppression of visibility
-- is needed for cases that are tested in B730006.
elsif Is_Private_Type (Original_Scope) elsif Is_Private_Type (Original_Scope)
or else or else
...@@ -11140,7 +11102,6 @@ package body Sem_Ch3 is ...@@ -11140,7 +11102,6 @@ package body Sem_Ch3 is
-- The class-wide type of a class-wide type is itself (RM 3.9(14)) -- The class-wide type of a class-wide type is itself (RM 3.9(14))
Set_Class_Wide_Type (CW_Type, CW_Type); Set_Class_Wide_Type (CW_Type, CW_Type);
end Make_Class_Wide_Type; end Make_Class_Wide_Type;
---------------- ----------------
...@@ -11267,7 +11228,7 @@ package body Sem_Ch3 is ...@@ -11267,7 +11228,7 @@ package body Sem_Ch3 is
elsif Nkind (I) = N_Subtype_Indication then elsif Nkind (I) = N_Subtype_Indication then
-- The index is given by a subtype with a range constraint. -- The index is given by a subtype with a range constraint
T := Base_Type (Entity (Subtype_Mark (I))); T := Base_Type (Entity (Subtype_Mark (I)));
...@@ -11317,6 +11278,7 @@ package body Sem_Ch3 is ...@@ -11317,6 +11278,7 @@ package body Sem_Ch3 is
Error_Msg_N ("invalid subtype mark in discrete range ", I); Error_Msg_N ("invalid subtype mark in discrete range ", I);
Set_Etype (I, Any_Integer); Set_Etype (I, Any_Integer);
return; return;
else else
-- The type mark may be that of an incomplete type. It is only -- The type mark may be that of an incomplete type. It is only
-- now that we can get the full view, previous analysis does -- now that we can get the full view, previous analysis does
...@@ -11383,10 +11345,9 @@ package body Sem_Ch3 is ...@@ -11383,10 +11345,9 @@ package body Sem_Ch3 is
-- not be recognized as the same type for the purposes of -- not be recognized as the same type for the purposes of
-- eliminating checks in some circumstances. -- eliminating checks in some circumstances.
-- We signal this case by setting the subtype entity in Def_Id. -- We signal this case by setting the subtype entity in Def_Id
if No (Def_Id) then if No (Def_Id) then
Def_Id := Def_Id :=
Create_Itype (E_Void, Related_Nod, Related_Id, 'D', Suffix_Index); Create_Itype (E_Void, Related_Nod, Related_Id, 'D', Suffix_Index);
Set_Etype (Def_Id, Base_Type (T)); Set_Etype (Def_Id, Base_Type (T));
...@@ -11526,7 +11487,7 @@ package body Sem_Ch3 is ...@@ -11526,7 +11487,7 @@ package body Sem_Ch3 is
return; return;
else else
-- In the non-binary case, set size as per RM 13.3(55). -- In the non-binary case, set size as per RM 13.3(55)
Set_Modular_Size (Bits); Set_Modular_Size (Bits);
return; return;
...@@ -11564,7 +11525,6 @@ package body Sem_Ch3 is ...@@ -11564,7 +11525,6 @@ package body Sem_Ch3 is
function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id is function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id is
Formal : Entity_Id; Formal : Entity_Id;
begin begin
Formal := New_Internal_Entity (E_In_Parameter, Op, Loc, 'P'); Formal := New_Internal_Entity (E_In_Parameter, Op, Loc, 'P');
Set_Etype (Formal, Typ); Set_Etype (Formal, Typ);
...@@ -11590,7 +11550,6 @@ package body Sem_Ch3 is ...@@ -11590,7 +11550,6 @@ package body Sem_Ch3 is
Append_Entity (Make_Op_Formal (Typ, Op), Op); Append_Entity (Make_Op_Formal (Typ, Op), Op);
Append_Entity (Make_Op_Formal (Typ, Op), Op); Append_Entity (Make_Op_Formal (Typ, Op), Op);
end New_Concatenation_Op; end New_Concatenation_Op;
------------------------------------------- -------------------------------------------
...@@ -12376,7 +12335,6 @@ package body Sem_Ch3 is ...@@ -12376,7 +12335,6 @@ package body Sem_Ch3 is
Next_Elmt (Inc_Elmt); Next_Elmt (Inc_Elmt);
end loop; end loop;
end Process_Incomplete_Dependents; end Process_Incomplete_Dependents;
-------------------------------- --------------------------------
...@@ -12746,7 +12704,6 @@ package body Sem_Ch3 is ...@@ -12746,7 +12704,6 @@ package body Sem_Ch3 is
-- Remaining processing depends on type -- Remaining processing depends on type
case Ekind (Subtype_Mark_Id) is case Ekind (Subtype_Mark_Id) is
when Access_Kind => when Access_Kind =>
Constrain_Access (Def_Id, S, Related_Nod); Constrain_Access (Def_Id, S, Related_Nod);
...@@ -12821,7 +12778,6 @@ package body Sem_Ch3 is ...@@ -12821,7 +12778,6 @@ package body Sem_Ch3 is
Set_Convention (Def_Id, Convention (Subtype_Mark_Id)); Set_Convention (Def_Id, Convention (Subtype_Mark_Id));
return Def_Id; return Def_Id;
end if; end if;
end Process_Subtype; end Process_Subtype;
...@@ -12844,7 +12800,8 @@ package body Sem_Ch3 is ...@@ -12844,7 +12800,8 @@ package body Sem_Ch3 is
-- if it detected an error for declaration T. This arises in the case of -- if it detected an error for declaration T. This arises in the case of
-- private tagged types where the full view omits the word tagged. -- private tagged types where the full view omits the word tagged.
Is_Tagged := Tagged_Present (Def) Is_Tagged :=
Tagged_Present (Def)
or else (Serious_Errors_Detected > 0 and then Is_Tagged_Type (T)); or else (Serious_Errors_Detected > 0 and then Is_Tagged_Type (T));
-- Records constitute a scope for the component declarations within. -- Records constitute a scope for the component declarations within.
...@@ -12972,7 +12929,6 @@ package body Sem_Ch3 is ...@@ -12972,7 +12929,6 @@ package body Sem_Ch3 is
Component := First_Entity (Current_Scope); Component := First_Entity (Current_Scope);
while Present (Component) loop while Present (Component) loop
if Ekind (Component) = E_Void then if Ekind (Component) = E_Void then
Set_Ekind (Component, E_Component); Set_Ekind (Component, E_Component);
Init_Component_Location (Component); Init_Component_Location (Component);
...@@ -13135,6 +13091,7 @@ package body Sem_Ch3 is ...@@ -13135,6 +13091,7 @@ package body Sem_Ch3 is
Subt : Entity_Id) Subt : Entity_Id)
is is
Kind : constant Entity_Kind := Ekind (Def_Id); Kind : constant Entity_Kind := Ekind (Def_Id);
begin begin
Set_Scalar_Range (Def_Id, R); Set_Scalar_Range (Def_Id, R);
...@@ -13165,8 +13122,7 @@ package body Sem_Ch3 is ...@@ -13165,8 +13122,7 @@ package body Sem_Ch3 is
(E : Entity_Id) (E : Entity_Id)
is is
begin begin
-- Make sure set if encountered during -- Make sure set if encountered during Expand_To_Stored_Constraint
-- Expand_To_Stored_Constraint
Set_Stored_Constraint (E, No_Elist); Set_Stored_Constraint (E, No_Elist);
...@@ -13176,7 +13132,6 @@ package body Sem_Ch3 is ...@@ -13176,7 +13132,6 @@ package body Sem_Ch3 is
Set_Stored_Constraint (E, Set_Stored_Constraint (E,
Expand_To_Stored_Constraint (E, Discriminant_Constraint (E))); Expand_To_Stored_Constraint (E, Discriminant_Constraint (E)));
end if; end if;
end Set_Stored_Constraint_From_Discriminant_Constraint; end Set_Stored_Constraint_From_Discriminant_Constraint;
------------------------------------- -------------------------------------
...@@ -13203,14 +13158,13 @@ package body Sem_Ch3 is ...@@ -13203,14 +13158,13 @@ package body Sem_Ch3 is
-- Can_Derive_From -- -- Can_Derive_From --
--------------------- ---------------------
-- Note we check both bounds against both end values, to deal with
-- strange types like ones with a range of 0 .. -12341234.
function Can_Derive_From (E : Entity_Id) return Boolean is function Can_Derive_From (E : Entity_Id) return Boolean is
Lo : constant Uint := Expr_Value (Type_Low_Bound (E)); Lo : constant Uint := Expr_Value (Type_Low_Bound (E));
Hi : constant Uint := Expr_Value (Type_High_Bound (E)); Hi : constant Uint := Expr_Value (Type_High_Bound (E));
begin begin
-- Note we check both bounds against both end values, to deal with
-- strange types like ones with a range of 0 .. -12341234.
return Lo <= Lo_Val and then Lo_Val <= Hi return Lo <= Lo_Val and then Lo_Val <= Hi
and then and then
Lo <= Hi_Val and then Hi_Val <= Hi; Lo <= Hi_Val and then Hi_Val <= Hi;
......
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