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).
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;
if No (Wrap_Node) then
null;
- 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;
+ -- 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.
- 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
+ elsif Nkind (Wrap_Node) = N_Iteration_Scheme then
+ null;
else
New_Scope (New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'));
(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"),
-- 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
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;
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
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);
when N_Derived_Type_Definition =>
null;
- -- For record types, discriminants are allowed.
+ -- For record types, discriminants are allowed
when N_Record_Definition =>
null;
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 --
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;
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);
Copy_And_Build;
Exchange_Declarations (Full_P);
- -- Otherwise it is a local derivation.
+ -- Otherwise it is a local derivation
else
Copy_And_Build;
-- 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
-- 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
-- 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
-- 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
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);
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;
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);
(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);
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);
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
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);
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);
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;
(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);
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
-- 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
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 --
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
-- Get_Discriminant_Value --
----------------------------
- -- This is the situation...
+ -- This is the situation:
-- There is a non-derived type
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
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);
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)
Set_Original_Record_Component (Id, Id);
- -- Create the discriminal for the discriminant.
+ -- Create the discriminal for the discriminant
Build_Discriminal (Id);
-- 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);
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;
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
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;
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));
-- 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);
Set_Etype (N, Subt);
end;
end if;
+
+ else
+ Set_Etype (N, Etype (Comp));
end if;
return;
------------------------------
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 --
--------------------------------------
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;
end if;
Check_Controlled_Array_Attribute (DS);
+
Make_Index (DS, LP);
Set_Ekind (Id, E_Loop_Parameter);
projects / platform / upstream / gcc.git / commitdiff