mirror of
git://gcc.gnu.org/git/gcc.git
synced 2025-04-06 02:10:29 +08:00
exp_ch4.adb (Expand_N_Selected_Component): If the component is the discriminant of a constrained subtype...
* exp_ch4.adb (Expand_N_Selected_Component): If the component is the discriminant of a constrained subtype, analyze the copy of the corresponding constraint, because in some cases it may be only partially analyzed. Removes long-lived ??? comments. * exp_ch7.adb (Establish_Transient_Scope): Remove complex code that handled controlled or secondary-stack expressions within the iteration_scheme of a loop. * sem_ch5.adb (Analyze_Iteration_Scheme): Build a block to evaluate bounds that may contain functions calls, to prevent memory leaks when the bound contains a call to a function that uses the secondary stack. (Check_Complex_Bounds): Subsidiary of Analyze_Iteration_Scheme, to generate temporaries for loop bounds that might contain function calls that require secondary stack and/or finalization actions. * sem_ch4.adb (Analyze_Indexed_Component_Form): If the prefix is a selected component and the selector is overloadable (not just a function) treat as function call, Analyze_Call will disambiguate if necessary. (Analyze_Selected_Component): Do not generate an actual subtype for the selected component if expansion is disabled. The actual subtype is only needed for constraint checks. (Analyze_Allocator): If restriction No_Streams is set, then do not permit objects to be declared of a stream type, or of a composite type containing a stream. * restrict.ads: Remove the a-stream entry from Unit_Array, since No_Streams no longer prohibits with'ing this package. * sem_ch3.adb (Build_Derived_Record_Type): If the parent type has discriminants, but the parent base has unknown discriminants, there is no discriminant constraint to inherit. Such a discrepancy can arise when the actual for a formal type with unknown discriminants is a similar private type whose full view has discriminants. (Analyze_Object_Declaration): If restriction No_Streams is set, then do not permit objects to be declared of a stream type, or of a composite type containing a stream. From-SVN: r90906
This commit is contained in:
Arnaud Charlet
parent
bc202b7006
commit
ffe9aba812
@ -5900,22 +5900,13 @@ package body Exp_Ch4 is
|
||||
elsif Nkind (Parent (N)) = N_Case_Statement
|
||||
and then Etype (Node (Dcon)) /= Etype (Disc)
|
||||
then
|
||||
-- RBKD is suspicious of the following code. The
|
||||
-- call to New_Copy instead of New_Copy_Tree is
|
||||
-- suspicious, and the call to Analyze instead
|
||||
-- of Analyze_And_Resolve is also suspicious ???
|
||||
|
||||
-- Wouldn't it be good enough to do a perfectly
|
||||
-- normal Analyze_And_Resolve call using the
|
||||
-- subtype of the discriminant here???
|
||||
|
||||
Rewrite (N,
|
||||
Make_Qualified_Expression (Loc,
|
||||
Subtype_Mark =>
|
||||
New_Occurrence_Of (Etype (Disc), Loc),
|
||||
Expression =>
|
||||
New_Copy (Node (Dcon))));
|
||||
Analyze (N);
|
||||
New_Copy_Tree (Node (Dcon))));
|
||||
Analyze_And_Resolve (N, Etype (Disc));
|
||||
|
||||
-- In case that comes out as a static expression,
|
||||
-- reset it (a selected component is never static).
|
||||
@ -5924,13 +5915,15 @@ package body Exp_Ch4 is
|
||||
return;
|
||||
|
||||
-- Otherwise we can just copy the constraint, but the
|
||||
-- result is certainly not static!
|
||||
|
||||
-- Again the New_Copy here and the failure to even
|
||||
-- to an analyze call is uneasy ???
|
||||
-- result is certainly not static! In some cases the
|
||||
-- discriminant constraint has been analyzed in the
|
||||
-- context of the original subtype indication, but for
|
||||
-- itypes the constraint might not have been analyzed
|
||||
-- yet, and this must be done now.
|
||||
|
||||
else
|
||||
Rewrite (N, New_Copy (Node (Dcon)));
|
||||
Rewrite (N, New_Copy_Tree (Node (Dcon)));
|
||||
Analyze_And_Resolve (N);
|
||||
Set_Is_Static_Expression (N, False);
|
||||
return;
|
||||
end if;
|
||||
|
||||
@ -1050,77 +1050,13 @@ package body Exp_Ch7 is
|
||||
if No (Wrap_Node) then
|
||||
null;
|
||||
|
||||
-- If the node to wrap is an iteration_scheme, the expression is
|
||||
-- one of the bounds, and the expansion will make an explicit
|
||||
-- declaration for it (see Analyze_Iteration_Scheme, sem_ch5.adb),
|
||||
-- so do not apply any transformations here.
|
||||
|
||||
elsif Nkind (Wrap_Node) = N_Iteration_Scheme then
|
||||
|
||||
-- Create a declaration followed by an assignment, so that
|
||||
-- the assignment can have its own transient scope.
|
||||
-- We generate the equivalent of:
|
||||
|
||||
-- type Ptr is access all expr_type;
|
||||
-- Var : Ptr;
|
||||
-- begin
|
||||
-- Var := Expr'reference;
|
||||
-- end;
|
||||
|
||||
-- This closely resembles what is done in Remove_Side_Effect,
|
||||
-- but it has to be done here, before the analysis of the call
|
||||
-- is completed.
|
||||
|
||||
declare
|
||||
Ptr_Typ : constant Entity_Id :=
|
||||
Make_Defining_Identifier (Loc,
|
||||
Chars => New_Internal_Name ('A'));
|
||||
Ptr : constant Entity_Id :=
|
||||
Make_Defining_Identifier (Loc,
|
||||
Chars => New_Internal_Name ('T'));
|
||||
|
||||
Expr_Type : constant Entity_Id := Etype (N);
|
||||
New_Expr : constant Node_Id := Relocate_Node (N);
|
||||
Decl : Node_Id;
|
||||
Ptr_Typ_Decl : Node_Id;
|
||||
Stmt : Node_Id;
|
||||
|
||||
begin
|
||||
Ptr_Typ_Decl :=
|
||||
Make_Full_Type_Declaration (Loc,
|
||||
Defining_Identifier => Ptr_Typ,
|
||||
Type_Definition =>
|
||||
Make_Access_To_Object_Definition (Loc,
|
||||
All_Present => True,
|
||||
Subtype_Indication =>
|
||||
New_Reference_To (Expr_Type, Loc)));
|
||||
|
||||
Decl :=
|
||||
Make_Object_Declaration (Loc,
|
||||
Defining_Identifier => Ptr,
|
||||
Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc));
|
||||
|
||||
Set_Etype (Ptr, Ptr_Typ);
|
||||
Stmt :=
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name => New_Occurrence_Of (Ptr, Loc),
|
||||
Expression => Make_Reference (Loc, New_Expr));
|
||||
|
||||
Set_Analyzed (New_Expr, False);
|
||||
|
||||
Insert_List_Before_And_Analyze
|
||||
(Parent (Wrap_Node),
|
||||
New_List (
|
||||
Ptr_Typ_Decl,
|
||||
Decl,
|
||||
Make_Block_Statement (Loc,
|
||||
Handled_Statement_Sequence =>
|
||||
Make_Handled_Sequence_Of_Statements (Loc,
|
||||
New_List (Stmt)))));
|
||||
|
||||
Rewrite (N,
|
||||
Make_Explicit_Dereference (Loc,
|
||||
Prefix => New_Reference_To (Ptr, Loc)));
|
||||
Analyze_And_Resolve (N, Expr_Type);
|
||||
|
||||
end;
|
||||
|
||||
-- Transient scope is required
|
||||
null;
|
||||
|
||||
else
|
||||
New_Scope (New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'));
|
||||
|
||||
@ -93,7 +93,6 @@ package Restrict is
|
||||
(No_IO, "text_io "),
|
||||
(No_IO, "a-witeio"),
|
||||
(No_Task_Attributes_Package, "a-tasatt"),
|
||||
(No_Streams, "a-stream"),
|
||||
(No_Unchecked_Conversion, "a-unccon"),
|
||||
(No_Unchecked_Conversion, "unchconv"),
|
||||
(No_Unchecked_Deallocation, "a-uncdea"),
|
||||
|
||||
@ -459,7 +459,7 @@ package body Sem_Ch3 is
|
||||
-- build the associated Implicit type name.
|
||||
|
||||
procedure Constrain_Integer (Def_Id : Node_Id; S : Node_Id);
|
||||
-- Build subtype of a signed or modular integer type.
|
||||
-- Build subtype of a signed or modular integer type
|
||||
|
||||
procedure Constrain_Ordinary_Fixed (Def_Id : Node_Id; S : Node_Id);
|
||||
-- Constrain an ordinary fixed point type with a range constraint, and
|
||||
@ -1415,7 +1415,7 @@ package body Sem_Ch3 is
|
||||
elsif It.Typ = Universal_Real
|
||||
or else It.Typ = Universal_Integer
|
||||
then
|
||||
-- Choose universal interpretation over any other.
|
||||
-- Choose universal interpretation over any other
|
||||
|
||||
T := It.Typ;
|
||||
exit;
|
||||
@ -1806,6 +1806,18 @@ package body Sem_Ch3 is
|
||||
Apply_Static_Length_Check (E, T);
|
||||
end if;
|
||||
|
||||
-- If the No_Streams restriction is set, check that the type of the
|
||||
-- object is not, and does not contain, any subtype derived from
|
||||
-- Ada.Streams.Root_Stream_Type. Note that we guard the call to
|
||||
-- Has_Stream just for efficiency reasons. There is no point in
|
||||
-- spending time on a Has_Stream check if the restriction is not set.
|
||||
|
||||
if Restrictions.Set (No_Streams) then
|
||||
if Has_Stream (T) then
|
||||
Check_Restriction (No_Streams, N);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- Abstract type is never permitted for a variable or constant.
|
||||
-- Note: we inhibit this check for objects that do not come from
|
||||
-- source because there is at least one case (the expansion of
|
||||
@ -1917,7 +1929,7 @@ package body Sem_Ch3 is
|
||||
|
||||
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_No_Initialization (N, False);
|
||||
@ -2759,7 +2771,7 @@ package body Sem_Ch3 is
|
||||
when N_Derived_Type_Definition =>
|
||||
null;
|
||||
|
||||
-- For record types, discriminants are allowed.
|
||||
-- For record types, discriminants are allowed
|
||||
|
||||
when N_Record_Definition =>
|
||||
null;
|
||||
@ -2940,7 +2952,7 @@ package body Sem_Ch3 is
|
||||
Process_Non_Static_Choice => Non_Static_Choice_Error,
|
||||
Process_Associated_Node => Process_Declarations);
|
||||
use Variant_Choices_Processing;
|
||||
-- Instantiation of the generic choice processing package.
|
||||
-- Instantiation of the generic choice processing package
|
||||
|
||||
-----------------------------
|
||||
-- Non_Static_Choice_Error --
|
||||
@ -2967,7 +2979,7 @@ package body Sem_Ch3 is
|
||||
end if;
|
||||
end Process_Declarations;
|
||||
|
||||
-- Variables local to Analyze_Case_Statement.
|
||||
-- Variables local to Analyze_Case_Statement
|
||||
|
||||
Discr_Name : Node_Id;
|
||||
Discr_Type : Entity_Id;
|
||||
@ -4180,7 +4192,7 @@ package body Sem_Ch3 is
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- Build partial view of derived type from partial view of parent.
|
||||
-- Build partial view of derived type from partial view of parent
|
||||
|
||||
Build_Derived_Record_Type
|
||||
(N, Parent_Type, Derived_Type, Derive_Subps);
|
||||
@ -4388,7 +4400,7 @@ package body Sem_Ch3 is
|
||||
Copy_And_Build;
|
||||
Exchange_Declarations (Full_P);
|
||||
|
||||
-- Otherwise it is a local derivation.
|
||||
-- Otherwise it is a local derivation
|
||||
|
||||
else
|
||||
Copy_And_Build;
|
||||
@ -4545,7 +4557,7 @@ package body Sem_Ch3 is
|
||||
-- in the derived type definition, then the discriminant is said to be
|
||||
-- "specified" by that derived type definition.
|
||||
|
||||
-- 3. DISCRIMINANTS IN DERIVED UNTAGGED RECORD TYPES.
|
||||
-- 3. DISCRIMINANTS IN DERIVED UNTAGGED RECORD TYPES
|
||||
|
||||
-- We have spoken about stored discriminants in point 1 (introduction)
|
||||
-- above. There are two sort of stored discriminants: implicit and
|
||||
@ -4720,7 +4732,7 @@ package body Sem_Ch3 is
|
||||
-- Discriminant_Constraint from Der so that when parameter conformance is
|
||||
-- checked when P is overridden, no semantic errors are flagged.
|
||||
|
||||
-- 6. SECOND TRANSFORMATION FOR DERIVED RECORDS.
|
||||
-- 6. SECOND TRANSFORMATION FOR DERIVED RECORDS
|
||||
|
||||
-- Regardless of whether we are dealing with a tagged or untagged type
|
||||
-- we will transform all derived type declarations of the form
|
||||
@ -4755,9 +4767,7 @@ package body Sem_Ch3 is
|
||||
-- type T2 (X : positive) is new R (1, X) [with null record];
|
||||
|
||||
-- As explained in 6. above, T1 is rewritten as
|
||||
|
||||
-- type T1 (D1, D2 : Positive) is new R (D1, D2) [with null record];
|
||||
|
||||
-- which makes the treatment for T1 and T2 identical.
|
||||
|
||||
-- What we want when inheriting S, is that references to D1 and D2 in R are
|
||||
@ -4877,7 +4887,7 @@ package body Sem_Ch3 is
|
||||
-- subtype T is BaseT (1);
|
||||
-- end;
|
||||
|
||||
-- (strictly speaking the above is incorrect Ada).
|
||||
-- (strictly speaking the above is incorrect Ada)
|
||||
|
||||
-- From the semantic standpoint the private view of private extension T
|
||||
-- should be flagged as constrained since one can clearly have
|
||||
@ -5037,7 +5047,7 @@ package body Sem_Ch3 is
|
||||
and then not Discriminant_Specs
|
||||
and then (Is_Constrained (Parent_Type) or else Constraint_Present)
|
||||
then
|
||||
-- First, we must analyze the constraint (see comment in point 5.).
|
||||
-- First, we must analyze the constraint (see comment in point 5.)
|
||||
|
||||
if Constraint_Present then
|
||||
New_Discrs := Build_Discriminant_Constraints (Parent_Type, Indic);
|
||||
@ -5379,6 +5389,7 @@ package body Sem_Ch3 is
|
||||
end if;
|
||||
|
||||
if not Has_Unknown_Discriminants (Derived_Type)
|
||||
and then not Has_Unknown_Discriminants (Parent_Base)
|
||||
and then Has_Discriminants (Parent_Type)
|
||||
then
|
||||
Inherit_Discrims := True;
|
||||
@ -5407,7 +5418,7 @@ package body Sem_Ch3 is
|
||||
or else Has_Unknown_Discriminants (Derived_Type)));
|
||||
end if;
|
||||
|
||||
-- STEP 3: initialize fields of derived type.
|
||||
-- STEP 3: initialize fields of derived type
|
||||
|
||||
Set_Is_Tagged_Type (Derived_Type, Is_Tagged);
|
||||
Set_Stored_Constraint (Derived_Type, No_Elist);
|
||||
@ -5441,7 +5452,7 @@ package body Sem_Ch3 is
|
||||
(Derived_Type, Finalize_Storage_Only (Parent_Type));
|
||||
end if;
|
||||
|
||||
-- Set fields for private derived types.
|
||||
-- Set fields for private derived types
|
||||
|
||||
if Is_Private_Type (Derived_Type) then
|
||||
Set_Depends_On_Private (Derived_Type, True);
|
||||
@ -5901,7 +5912,7 @@ package body Sem_Ch3 is
|
||||
|
||||
while Present (Constr) loop
|
||||
|
||||
-- Positional association forbidden after a named association.
|
||||
-- Positional association forbidden after a named association
|
||||
|
||||
if Nkind (Constr) /= N_Discriminant_Association then
|
||||
Error_Msg_N ("positional association follows named one", Constr);
|
||||
@ -6025,7 +6036,7 @@ package body Sem_Ch3 is
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
-- Determine if there are discriminant expressions in the constraint.
|
||||
-- Determine if there are discriminant expressions in the constraint
|
||||
|
||||
for J in Discr_Expr'Range loop
|
||||
if Denotes_Discriminant (Discr_Expr (J), Check_Protected => True) then
|
||||
@ -6813,7 +6824,7 @@ package body Sem_Ch3 is
|
||||
begin
|
||||
if Has_Discriminants (T) then
|
||||
|
||||
-- Make the discriminants visible to component declarations.
|
||||
-- Make the discriminants visible to component declarations
|
||||
|
||||
declare
|
||||
D : Entity_Id := First_Discriminant (T);
|
||||
@ -7752,7 +7763,7 @@ package body Sem_Ch3 is
|
||||
|
||||
Set_Parent (Subtyp_Decl, Parent (Related_Node));
|
||||
|
||||
-- Itypes must be analyzed with checks off (see itypes.ads).
|
||||
-- Itypes must be analyzed with checks off (see package Itypes)
|
||||
|
||||
Analyze (Subtyp_Decl, Suppress => All_Checks);
|
||||
|
||||
@ -7859,7 +7870,7 @@ package body Sem_Ch3 is
|
||||
return True;
|
||||
end if;
|
||||
|
||||
-- In all other cases we have something wrong.
|
||||
-- In all other cases we have something wrong
|
||||
|
||||
return False;
|
||||
end Is_Discriminant;
|
||||
@ -8252,7 +8263,7 @@ package body Sem_Ch3 is
|
||||
(Nkind (S) = N_Attribute_Reference
|
||||
and then Attribute_Name (S) = Name_Range)
|
||||
then
|
||||
-- A Range attribute will transformed into N_Range by Resolve.
|
||||
-- A Range attribute will transformed into N_Range by Resolve
|
||||
|
||||
Analyze (S);
|
||||
Set_Etype (S, T);
|
||||
@ -8488,7 +8499,7 @@ package body Sem_Ch3 is
|
||||
then
|
||||
return;
|
||||
|
||||
-- Here we do the analysis of the range.
|
||||
-- Here we do the analysis of the range
|
||||
|
||||
-- Note: we do this manually, since if we do a normal Analyze and
|
||||
-- Resolve call, there are problems with the conversions used for
|
||||
@ -8642,7 +8653,7 @@ package body Sem_Ch3 is
|
||||
-- Collect parent type components that do not appear in a variant part
|
||||
|
||||
procedure Create_All_Components;
|
||||
-- Iterate over Comp_List to create the components of the subtype.
|
||||
-- Iterate over Comp_List to create the components of the subtype
|
||||
|
||||
function Create_Component (Old_Compon : Entity_Id) return Entity_Id;
|
||||
-- Creates a new component from Old_Compon, copying all the fields from
|
||||
@ -9822,7 +9833,7 @@ package body Sem_Ch3 is
|
||||
Discriminant : Entity_Id;
|
||||
|
||||
function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id;
|
||||
-- Find the nearest type that actually specifies discriminants.
|
||||
-- Find the nearest type that actually specifies discriminants
|
||||
|
||||
---------------------------------
|
||||
-- Type_With_Explicit_Discrims --
|
||||
@ -10101,7 +10112,7 @@ package body Sem_Ch3 is
|
||||
T := Empty;
|
||||
Array_Type_Declaration (T, Obj_Def);
|
||||
|
||||
-- Create an explicit subtype whenever possible.
|
||||
-- Create an explicit subtype whenever possible
|
||||
|
||||
elsif Nkind (P) /= N_Component_Declaration
|
||||
and then Def_Kind = N_Subtype_Indication
|
||||
@ -10337,7 +10348,7 @@ package body Sem_Ch3 is
|
||||
-- Get_Discriminant_Value --
|
||||
----------------------------
|
||||
|
||||
-- This is the situation...
|
||||
-- This is the situation:
|
||||
|
||||
-- There is a non-derived type
|
||||
|
||||
@ -10709,7 +10720,7 @@ package body Sem_Ch3 is
|
||||
while Present (Discrim) loop
|
||||
Corr_Discrim := Corresponding_Discriminant (Discrim);
|
||||
|
||||
-- Corr_Discrimm could be missing in an error situation.
|
||||
-- Corr_Discrimm could be missing in an error situation
|
||||
|
||||
if Present (Corr_Discrim)
|
||||
and then Original_Record_Component (Corr_Discrim) = Old_C
|
||||
@ -10746,7 +10757,7 @@ package body Sem_Ch3 is
|
||||
Append_Elmt (Derived_Base, Assoc_List);
|
||||
end if;
|
||||
|
||||
-- Inherit parent discriminants if needed.
|
||||
-- Inherit parent discriminants if needed
|
||||
|
||||
if Inherit_Discr then
|
||||
Parent_Discrim := First_Discriminant (Parent_Base);
|
||||
@ -10756,7 +10767,7 @@ package body Sem_Ch3 is
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
-- Create explicit stored discrims for untagged types when necessary.
|
||||
-- Create explicit stored discrims for untagged types when necessary
|
||||
|
||||
if not Has_Unknown_Discriminants (Derived_Base)
|
||||
and then Has_Discriminants (Parent_Base)
|
||||
@ -11915,7 +11926,7 @@ package body Sem_Ch3 is
|
||||
|
||||
Set_Original_Record_Component (Id, Id);
|
||||
|
||||
-- Create the discriminal for the discriminant.
|
||||
-- Create the discriminal for the discriminant
|
||||
|
||||
Build_Discriminal (Id);
|
||||
|
||||
@ -12852,7 +12863,8 @@ package body Sem_Ch3 is
|
||||
-- expanded as part of the freezing actions if it is not a CPP_Class.
|
||||
|
||||
if Is_Tagged then
|
||||
-- Do not add the tag unless we are in expansion mode.
|
||||
|
||||
-- Do not add the tag unless we are in expansion mode
|
||||
|
||||
if Expander_Active then
|
||||
Tag_Comp := Make_Defining_Identifier (Sloc (Def), Name_uTag);
|
||||
|
||||
@ -324,7 +324,7 @@ package body Sem_Ch4 is
|
||||
procedure Analyze_Allocator (N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Sav_Errs : constant Nat := Serious_Errors_Detected;
|
||||
E : Node_Id := Expression (N);
|
||||
E : Node_Id := Expression (N);
|
||||
Acc_Type : Entity_Id;
|
||||
Type_Id : Entity_Id;
|
||||
|
||||
@ -498,6 +498,18 @@ package body Sem_Ch4 is
|
||||
Check_Restriction (No_Task_Allocators, N);
|
||||
end if;
|
||||
|
||||
-- If the No_Streams restriction is set, check that the type of the
|
||||
-- object is not, and does not contain, any subtype derived from
|
||||
-- Ada.Streams.Root_Stream_Type. Note that we guard the call to
|
||||
-- Has_Stream just for efficiency reasons. There is no point in
|
||||
-- spending time on a Has_Stream check if the restriction is not set.
|
||||
|
||||
if Restrictions.Set (No_Streams) then
|
||||
if Has_Stream (Designated_Type (Acc_Type)) then
|
||||
Check_Restriction (No_Streams, N);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
Set_Etype (N, Acc_Type);
|
||||
|
||||
if not Is_Library_Level_Entity (Acc_Type) then
|
||||
@ -1662,7 +1674,7 @@ package body Sem_Ch4 is
|
||||
Process_Function_Call;
|
||||
|
||||
elsif Nkind (P) = N_Selected_Component
|
||||
and then Ekind (Entity (Selector_Name (P))) = E_Function
|
||||
and then Is_Overloadable (Entity (Selector_Name (P)))
|
||||
then
|
||||
Process_Function_Call;
|
||||
|
||||
@ -2614,11 +2626,11 @@ package body Sem_Ch4 is
|
||||
or else
|
||||
(Nkind (Parent_N) = N_Attribute_Reference
|
||||
and then (Attribute_Name (Parent_N) = Name_First
|
||||
or else
|
||||
or else
|
||||
Attribute_Name (Parent_N) = Name_Last
|
||||
or else
|
||||
or else
|
||||
Attribute_Name (Parent_N) = Name_Length
|
||||
or else
|
||||
or else
|
||||
Attribute_Name (Parent_N) = Name_Range)))
|
||||
then
|
||||
Set_Etype (N, Etype (Comp));
|
||||
@ -2630,7 +2642,10 @@ package body Sem_Ch4 is
|
||||
-- not make an actual subtype, we end up getting a direct
|
||||
-- reference to a discriminant which will not do.
|
||||
|
||||
else
|
||||
-- Comment needs revision, "in all other cases" does not
|
||||
-- reasonably describe the situation below with an elsif???
|
||||
|
||||
elsif Expander_Active then
|
||||
Act_Decl :=
|
||||
Build_Actual_Subtype_Of_Component (Etype (Comp), N);
|
||||
Insert_Action (N, Act_Decl);
|
||||
@ -2652,6 +2667,9 @@ package body Sem_Ch4 is
|
||||
Set_Etype (N, Subt);
|
||||
end;
|
||||
end if;
|
||||
|
||||
else
|
||||
Set_Etype (N, Etype (Comp));
|
||||
end if;
|
||||
|
||||
return;
|
||||
|
||||
@ -1105,12 +1105,111 @@ package body Sem_Ch5 is
|
||||
------------------------------
|
||||
|
||||
procedure Analyze_Iteration_Scheme (N : Node_Id) is
|
||||
|
||||
procedure Process_Bounds (R : Node_Id);
|
||||
-- If the iteration is given by a range, create temporaries and
|
||||
-- assignment statements block to capture the bounds and perform
|
||||
-- required finalization actions in case a bound includes a function
|
||||
-- call that uses the temporary stack.
|
||||
|
||||
procedure Check_Controlled_Array_Attribute (DS : Node_Id);
|
||||
-- If the bounds are given by a 'Range reference on a function call
|
||||
-- that returns a controlled array, introduce an explicit declaration
|
||||
-- to capture the bounds, so that the function result can be finalized
|
||||
-- in timely fashion.
|
||||
|
||||
--------------------
|
||||
-- Process_Bounds --
|
||||
--------------------
|
||||
|
||||
procedure Process_Bounds (R : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Lo : constant Node_Id := Low_Bound (R);
|
||||
Hi : constant Node_Id := High_Bound (R);
|
||||
New_Lo_Bound : Node_Id := Empty;
|
||||
New_Hi_Bound : Node_Id := Empty;
|
||||
Typ : constant Entity_Id := Etype (R);
|
||||
|
||||
function One_Bound (Bound : Node_Id) return Node_Id;
|
||||
-- Create one declaration followed by one assignment statement
|
||||
-- to capture the value of bound. We create a separate assignment
|
||||
-- in order to force the creation of a block in case the bound
|
||||
-- contains a call that uses the secondary stack.
|
||||
|
||||
---------------
|
||||
-- One_Bound --
|
||||
---------------
|
||||
|
||||
function One_Bound (Bound : Node_Id) return Node_Id is
|
||||
Assign : Node_Id;
|
||||
Id : Entity_Id;
|
||||
Decl : Node_Id;
|
||||
|
||||
begin
|
||||
-- If the bound is a constant or an object, no need for a
|
||||
-- separate declaration. If the bound is the result of previous
|
||||
-- expansion it is already analyzed and should not be modified.
|
||||
|
||||
if Nkind (Bound) = N_Integer_Literal
|
||||
or else Is_Entity_Name (Bound)
|
||||
or else Analyzed (Bound)
|
||||
then
|
||||
Resolve (Bound, Typ);
|
||||
return Bound;
|
||||
end if;
|
||||
|
||||
Id :=
|
||||
Make_Defining_Identifier (Loc,
|
||||
Chars => New_Internal_Name ('S'));
|
||||
|
||||
Decl :=
|
||||
Make_Object_Declaration (Loc,
|
||||
Defining_Identifier => Id,
|
||||
Object_Definition => New_Occurrence_Of (Typ, Loc));
|
||||
|
||||
Insert_Before (Parent (N), Decl);
|
||||
Analyze (Decl);
|
||||
|
||||
Assign :=
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name => New_Occurrence_Of (Id, Loc),
|
||||
Expression => Relocate_Node (Bound));
|
||||
|
||||
Save_Interps (Bound, Expression (Assign));
|
||||
Insert_Before (Parent (N), Assign);
|
||||
Analyze (Assign);
|
||||
|
||||
Rewrite (Bound, New_Occurrence_Of (Id, Loc));
|
||||
|
||||
if Nkind (Assign) = N_Assignment_Statement then
|
||||
return Expression (Assign);
|
||||
else
|
||||
return Bound;
|
||||
end if;
|
||||
end One_Bound;
|
||||
|
||||
-- Start of processing for Process_Bounds
|
||||
|
||||
begin
|
||||
New_Lo_Bound := One_Bound (Lo);
|
||||
New_Hi_Bound := One_Bound (Hi);
|
||||
|
||||
-- Propagate staticness to loop range itself, in case the
|
||||
-- corresponding subtype is static.
|
||||
|
||||
if New_Lo_Bound /= Lo
|
||||
and then Is_Static_Expression (New_Lo_Bound)
|
||||
then
|
||||
Rewrite (Low_Bound (R), New_Copy (New_Lo_Bound));
|
||||
end if;
|
||||
|
||||
if New_Hi_Bound /= Hi
|
||||
and then Is_Static_Expression (New_Hi_Bound)
|
||||
then
|
||||
Rewrite (High_Bound (R), New_Copy (New_Hi_Bound));
|
||||
end if;
|
||||
end Process_Bounds;
|
||||
|
||||
--------------------------------------
|
||||
-- Check_Controlled_Array_Attribute --
|
||||
--------------------------------------
|
||||
@ -1212,9 +1311,17 @@ package body Sem_Ch5 is
|
||||
end if;
|
||||
end;
|
||||
|
||||
-- Now analyze the subtype definition
|
||||
-- Now analyze the subtype definition. If it is
|
||||
-- a range, create temporaries for bounds.
|
||||
|
||||
Analyze (DS);
|
||||
if Nkind (DS) = N_Range
|
||||
and then Expander_Active
|
||||
then
|
||||
Pre_Analyze_And_Resolve (DS);
|
||||
Process_Bounds (DS);
|
||||
else
|
||||
Analyze (DS);
|
||||
end if;
|
||||
|
||||
if DS = Error then
|
||||
return;
|
||||
@ -1238,6 +1345,7 @@ package body Sem_Ch5 is
|
||||
end if;
|
||||
|
||||
Check_Controlled_Array_Attribute (DS);
|
||||
|
||||
Make_Index (DS, LP);
|
||||
|
||||
Set_Ekind (Id, E_Loop_Parameter);
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user