[Ada] fix bad handling of function returning controlled
Arnaud Charlet
charlet@adacore.com
Fri Nov 19 10:53:00 GMT 2004
Tested on x86-linux, committed on mainline.
When the expression for a bound contains a call to a function that returns
a value that needs to be finalized, finalization must take place before
the loop execution starts, but after the value for the bound itself is
computed. In some cases the previous scheme finalized the value too early,
leading to incorrect execution.
The fix consists in generating an explicit temporary for any bound that
might contain a function call.
Test case: Program must execute quietly.
--
$ gnatmake p
$ p
--
with Ada.Text_IO; with Typ; use Typ;
procedure P is
Count : Natural := 0;
type Arr is array (Integer range <>) of Integer;
Thing : Arr := (1..Get_Value (Make_T (42)) => 11);
begin
if Get_Value (Make_T (12)) /= 12 then raise Program_Error; end if;
if Thing'Last /= 42 then raise Program_Error; end if;
for J in 1 .. Get_Value (Make_T (23)) loop
Count := Count + 1;
end loop;
if Count /= 23 then
Ada.Text_IO.Put_Line ("FAILED Iterated" & Count'Img & " times");
end if;
end P;
with Ada.Finalization;
package Typ is
type T is new Ada.Finalization.Controlled with record
Val : Natural := 1;
end record;
function Make_T (N : Natural) return T;
function Get_Value (X : T) return Natural;
procedure Finalize (X : in out T);
end Typ;
package body Typ is
A_T : T;
function Make_T (N : Natural) return T is
begin
A_T.Val := N; return A_T;
end Make_T;
function Get_Value (X : T) return Natural is
begin
return X.Val;
end Get_Value;
procedure Finalize (X : in out T) is begin X.Val := 0; end Finalize;
end Typ;
While working on these changes, also uncovered another issue:
The indexed component form can be an indexed component, a slice, a call,
the indexing of a parameterless call, or a call to an element of an entry
family. If the prefix is a selected component, it can be a call to a
protected operation. In that case the selector will be an overloadable
entity (function, procedure or entry). If the name of the selector is
overloaded in the corresponding protected type, the recorded entity can
be any of the those and the context will disambiguate, so it is incorrect
to assume that this is a call only if the selector is a function.
Test case:
Expected output: ' 17'
$ gnatmake overloaded_op
$ overloaded_op
--
with text_io; use text_io;
procedure Overloaded_Op is
protected Buffer is
procedure Get (x, y : in Integer);
function Get (x : in Integer) return Integer;
entry Extract;
function Extract (x : integer) return Integer;
private
Buffer : Integer;
end Buffer;
protected body Buffer is
procedure Get (x, y : in Integer) is begin null; end Get;
function Get (x : in Integer) return Integer is begin return 17; end Get;
entry Extract when true is begin null; end;
function Extract (x : Integer) return Integer is
begin
return Buffer + 1;
end;
end Buffer;
DATA : constant Integer := Buffer.Get(1);
begin
put_line (integer'image (data)); Buffer.Get (5, 6); Buffer.Extract;
end Overloaded_Op;
This patch also changes the meaning of the restriction No_Streams in
a way that makes it far more useful. Instead of forbidding any
attempt to WITH the Ada.Streams package, this restriction now
forbids any attempt to create a stream object, either with an
object declaration, or with an allocator. So it is possible to
use packages that WITH Ada.Streams in the presence of this
restriction pragma as long as no actual stream objects are
created.
2004-11-18 Ed Schonberg <schonberg@adacore.com>
Robert Dewar <dewar@adacore.com>
* 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.
-------------- next part --------------
Index: exp_ch4.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch4.adb,v
retrieving revision 1.29
diff -u -p -r1.29 exp_ch4.adb
--- exp_ch4.adb 27 Oct 2004 13:01:37 -0000 1.29
+++ exp_ch4.adb 19 Nov 2004 10:35:03 -0000
@@ -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;
Index: exp_ch7.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch7.adb,v
retrieving revision 1.17
diff -u -p -r1.17 exp_ch7.adb
--- exp_ch7.adb 9 Aug 2004 12:24:14 -0000 1.17
+++ exp_ch7.adb 19 Nov 2004 10:35:03 -0000
@@ -1050,77 +1050,13 @@ package body Exp_Ch7 is
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;
-
- 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;
+ -- 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.
- -- 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'));
Index: sem_ch5.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch5.adb,v
retrieving revision 1.17
diff -u -p -r1.17 sem_ch5.adb
--- sem_ch5.adb 4 Oct 2004 15:00:06 -0000 1.17
+++ sem_ch5.adb 19 Nov 2004 10:35:03 -0000
@@ -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);
Index: sem_ch4.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch4.adb,v
retrieving revision 1.32
diff -u -p -r1.32 sem_ch4.adb
--- sem_ch4.adb 27 Oct 2004 12:29:19 -0000 1.32
+++ sem_ch4.adb 19 Nov 2004 10:35:04 -0000
@@ -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;
Index: restrict.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/restrict.ads,v
retrieving revision 1.11
diff -u -p -r1.11 restrict.ads
--- restrict.ads 14 Jun 2004 13:19:04 -0000 1.11
+++ restrict.ads 19 Nov 2004 10:35:04 -0000
@@ -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"),
Index: sem_ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch3.adb,v
retrieving revision 1.53
diff -u -p -r1.53 sem_ch3.adb
--- sem_ch3.adb 27 Oct 2004 13:41:55 -0000 1.53
+++ sem_ch3.adb 19 Nov 2004 10:35:04 -0000
@@ -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);
More information about the Gcc-patches
mailing list