OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

gnat_ugn.texi: Minor spelling correction. 

2014-07-30  Robert Dewar  <dewar@adacore.com>

	* gnat_ugn.texi: Minor spelling correction.
	* makeutl.adb: Minor code reorganization.
	* exp_ch4.adb, exp_aggr.adb, exp_ch3.adb: Minor reformatting.

2014-07-30  Robert Dewar  <dewar@adacore.com>

	* einfo.ads (Has_Unchecked_Union): Document that this is used
	to check for illegal Valid_Scalars attribute references.
	* exp_attr.adb (Build_Record_VS_Func): New function
	(Expand_N_Attribute_Reference, case Valid_Scalars): Call this
	function.
	* gnat_rm.texi: Document 'Valid_Scalars cannot be applied to
	Unchecked_Union Add note on 'Valid_Scalars generating a lot
	of code.
	* sem_attr.adb (Analyze_Attribute, case Valid_Scalars): Give
	error on attempt to apply Valid_Scalars to Unchecked_Union type.

From-SVN: r213298
This commit is contained in:
Robert Dewar 2014-07-30 15:13:23 +00:00 committed by Arnaud Charlet
parent ad9560ea43
commit 45ec05e18a
10 changed files with 399 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
gcc/ada/ChangeLog
View File

@ -1,3 +1,22 @@
2014-07-30 Robert Dewar <dewar@adacore.com>
* gnat_ugn.texi: Minor spelling correction.
* makeutl.adb: Minor code reorganization.
* exp_ch4.adb, exp_aggr.adb, exp_ch3.adb: Minor reformatting.
2014-07-30 Robert Dewar <dewar@adacore.com>
* einfo.ads (Has_Unchecked_Union): Document that this is used
to check for illegal Valid_Scalars attribute references.
* exp_attr.adb (Build_Record_VS_Func): New function
(Expand_N_Attribute_Reference, case Valid_Scalars): Call this
function.
* gnat_rm.texi: Document 'Valid_Scalars cannot be applied to
Unchecked_Union Add note on 'Valid_Scalars generating a lot
of code.
* sem_attr.adb (Analyze_Attribute, case Valid_Scalars): Give
error on attempt to apply Valid_Scalars to Unchecked_Union type.
2014-07-30 Steve Baird <baird@adacore.com>
* exp_ch4.adb (Expand_N_Indexed_Component): Disable optimized handling

6
gcc/ada/einfo.ads
View File

@ -1955,9 +1955,9 @@ package Einfo is
-- Defined in all type entities. Set on unchecked unions themselves
-- and (recursively) on any composite type which has a component for
-- which Has_Unchecked_Union is set. The meaning is that a comparison
-- operation for the type is not permitted. Note that the flag is not
-- set on access types, even if they designate an object that has
-- the flag Has_Unchecked_Union set.
-- operation or 'Valid_Scalars reference for the type is not permitted.
-- Note that the flag is not set on access types, even if they designate
-- an object that has the flag Has_Unchecked_Union set.
-- Has_Unknown_Discriminants (Flag72)
-- Defined in all entities. Set for types with unknown discriminants.

5
gcc/ada/exp_aggr.adb
View File

@ -2847,12 +2847,11 @@ package body Exp_Aggr is
then
declare
Assoc : constant Node_Id :=
First (Component_Associations (Expr_Q));
First (Component_Associations (Expr_Q));
Decl : Node_Id;
begin
if
Nkind (First (Choices (Assoc))) = N_Others_Choice
if Nkind (First (Choices (Assoc))) = N_Others_Choice
then
Decl :=
Build_Actual_Subtype_Of_Component

323
gcc/ada/exp_attr.adb
View File

@ -84,6 +84,14 @@ package body Exp_Attr is
-- value returned is the entity of the constructed function body. We do not
-- bother to generate a separate spec for this subprogram.
function Build_Record_VS_Func
(R_Type : Entity_Id;
Nod : Node_Id) return Entity_Id;
-- Build function to test Valid_Scalars for record type A_Type. Nod is the
-- Valid_Scalars attribute node, used to insert the function body, and the
-- value returned is the entity of the constructed function body. We do not
-- bother to generate a separate spec for this subprogram.
procedure Compile_Stream_Body_In_Scope
(N : Node_Id;
Decl : Node_Id;
@ -202,10 +210,10 @@ package body Exp_Attr is
Nod : Node_Id) return Entity_Id
is
Loc : constant Source_Ptr := Sloc (Nod);
Func_Id : constant Entity_Id := Make_Temporary (Loc, 'V');
Comp_Type : constant Entity_Id := Component_Type (A_Type);
Body_Stmts : List_Id;
Index_List : List_Id;
Func_Id : Entity_Id;
Formals : List_Id;
function Test_Component return List_Id;
@ -298,8 +306,6 @@ package body Exp_Attr is
begin
Index_List := New_List;
Func_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('V'));
Body_Stmts := Test_One_Dimension (1);
-- Parameter is always (A : A_Typ)
@ -333,9 +339,279 @@ package body Exp_Attr is
Set_Debug_Info_Off (Func_Id);
end if;
Set_Is_Pure (Func_Id);
return Func_Id;
end Build_Array_VS_Func;
--------------------------
-- Build_Record_VS_Func --
--------------------------
-- Generates:
-- function _Valid_Scalars (X : T) return Boolean is
-- begin
-- -- Check discriminants
-- if not X.D1'Valid_Scalars or else
-- not X.D2'Valid_Scalars or else
-- ...
-- then
-- return False;
-- end if;
-- -- Check components
-- if not X.C1'Valid_Scalars or else
-- not X.C2'Valid_Scalars or else
-- ...
-- then
-- return False;
-- end if;
-- -- Check variant part
-- case X.D1 is
-- when V1 =>
-- if not X.C2'Valid_Scalars or else
-- not X.C3'Valid_Scalars or else
-- ...
-- then
-- return False;
-- end if;
-- ...
-- when Vn =>
-- if not X.Cn'Valid_Scalars or else
-- ...
-- then
-- return False;
-- end if;
-- end case;
-- return True;
-- end _Valid_Scalars;
function Build_Record_VS_Func
(R_Type : Entity_Id;
Nod : Node_Id) return Entity_Id
is
Loc : constant Source_Ptr := Sloc (R_Type);
Func_Id : constant Entity_Id := Make_Temporary (Loc, 'V');
X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_X);
function Make_VS_Case
(E : Entity_Id;
CL : Node_Id;
Discrs : Elist_Id := New_Elmt_List) return List_Id;
-- Building block for variant valid scalars. Given a Component_List node
-- CL, it generates an 'if' followed by a 'case' statement that compares
-- all components of local temporaries named X and Y (that are declared
-- as formals at some upper level). E provides the Sloc to be used for
-- the generated code.
function Make_VS_If
(E : Entity_Id;
L : List_Id) return Node_Id;
-- Building block for variant validate scalars. Given the list, L, of
-- components (or discriminants) L, it generates a return statement that
-- compares all components of local temporaries named X and Y (that are
-- declared as formals at some upper level). E provides the Sloc to be
-- used for the generated code.
------------------
-- Make_VS_Case --
------------------
-- <Make_VS_If on shared components>
-- case X.D1 is
-- when V1 => <Make_VS_Case> on subcomponents
-- ...
-- when Vn => <Make_VS_Case> on subcomponents
-- end case;
function Make_VS_Case
(E : Entity_Id;
CL : Node_Id;
Discrs : Elist_Id := New_Elmt_List) return List_Id
is
Loc : constant Source_Ptr := Sloc (E);
Result : constant List_Id := New_List;
Variant : Node_Id;
Alt_List : List_Id;
begin
Append_To (Result, Make_VS_If (E, Component_Items (CL)));
if No (Variant_Part (CL)) then
return Result;
end if;
Variant := First_Non_Pragma (Variants (Variant_Part (CL)));
if No (Variant) then
return Result;
end if;
Alt_List := New_List;
while Present (Variant) loop
Append_To (Alt_List,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)),
Statements =>
Make_VS_Case (E, Component_List (Variant), Discrs)));
Next_Non_Pragma (Variant);
end loop;
Append_To (Result,
Make_Case_Statement (Loc,
Expression =>
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_X),
Selector_Name => New_Copy (Name (Variant_Part (CL)))),
Alternatives => Alt_List));
return Result;
end Make_VS_Case;
----------------
-- Make_VS_If --
----------------
-- Generates:
-- if
-- not X.C1'Valid_Scalars
-- or else
-- not X.C2'Valid_Scalars
-- ...
-- then
-- return False;
-- end if;
-- or a null statement if the list L is empty
function Make_VS_If
(E : Entity_Id;
L : List_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (E);
C : Node_Id;
Def_Id : Entity_Id;
Field_Name : Name_Id;
Cond : Node_Id;
begin
if No (L) then
return Make_Null_Statement (Loc);
else
Cond := Empty;
C := First_Non_Pragma (L);
while Present (C) loop
Def_Id := Defining_Identifier (C);
Field_Name := Chars (Def_Id);
-- The tags need not be checked since they will always be valid
-- Note also that in the following, we use Make_Identifier for
-- the component names. Use of New_Occurrence_Of to identify
-- the components would be incorrect because wrong entities for
-- discriminants could be picked up in the private type case.
-- Don't bother with abstract parent in interface case
if Field_Name = Name_uParent
and then Is_Interface (Etype (Def_Id))
then
null;
-- Don't bother with tag, always valid, and not scalar anyway
elsif Field_Name = Name_uTag then
null;
-- Don't bother with component with no scalar components
elsif not Scalar_Part_Present (Etype (Def_Id)) then
null;
-- Normal case, generate Valid_Scalars attribute reference
else
Evolve_Or_Else (Cond,
Make_Op_Not (Loc,
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Make_Identifier (Loc, Name_X),
Selector_Name =>
Make_Identifier (Loc, Field_Name)),
Attribute_Name => Name_Valid_Scalars)));
end if;
Next_Non_Pragma (C);
end loop;
if No (Cond) then
return Make_Null_Statement (Loc);
else
return
Make_Implicit_If_Statement (E,
Condition => Cond,
Then_Statements => New_List (
Make_Simple_Return_Statement (Loc,
Expression =>
New_Occurrence_Of (Standard_False, Loc))));
end if;
end if;
end Make_VS_If;
-- Local Declarations
Def : constant Node_Id := Parent (R_Type);
Comps : constant Node_Id := Component_List (Type_Definition (Def));
Stmts : constant List_Id := New_List;
Pspecs : constant List_Id := New_List;
begin
Append_To (Pspecs,
Make_Parameter_Specification (Loc,
Defining_Identifier => X,
Parameter_Type => New_Occurrence_Of (R_Type, Loc)));
Append_To (Stmts,
Make_VS_If (R_Type, Discriminant_Specifications (Def)));
Append_List_To (Stmts, Make_VS_Case (R_Type, Comps));
Append_To (Stmts,
Make_Simple_Return_Statement (Loc,
Expression => New_Occurrence_Of (Standard_True, Loc)));
Insert_Action (Nod,
Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => Func_Id,
Parameter_Specifications => Pspecs,
Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)),
Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)),
Suppress => Discriminant_Check);
if not Debug_Generated_Code then
Set_Debug_Info_Off (Func_Id);
end if;
Set_Is_Pure (Func_Id);
return Func_Id;
end Build_Record_VS_Func;
----------------------------------
-- Compile_Stream_Body_In_Scope --
----------------------------------
@ -6377,14 +6653,18 @@ package body Exp_Attr is
Ftyp := Ptyp;
end if;
-- Replace by True if no scalar parts
if not Scalar_Part_Present (Ftyp) then
Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
-- For scalar types, Valid_Scalars is the same as Valid
if Is_Scalar_Type (Ftyp) then
elsif Is_Scalar_Type (Ftyp) then
Rewrite (N,
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Valid,
Prefix => Pref));
Analyze_And_Resolve (N, Standard_Boolean);
-- For array types, we construct a function that determines if there
-- are any non-valid scalar subcomponents, and call the function.
@ -6399,14 +6679,25 @@ package body Exp_Attr is
New_Occurrence_Of (Build_Array_VS_Func (Ftyp, N), Loc),
Parameter_Associations => New_List (Pref)));
Analyze_And_Resolve (N, Standard_Boolean);
-- For record types, we construct a function that determines if there
-- are any non-valid scalar subcomponents, and call the function.
-- For record types, we build a big if expression, applying Valid or
-- Valid_Scalars as appropriate to all relevant components.
elsif (Is_Record_Type (Ptyp) or else Has_Discriminants (Ptyp))
and then Scalar_Part_Present (Ptyp)
elsif Is_Record_Type (Ftyp)
and then Nkind (Type_Definition (Declaration_Node (Ftyp))) =
N_Record_Definition
then
Rewrite (N,
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (Build_Record_VS_Func (Ftyp, N), Loc),
Parameter_Associations => New_List (Pref)));
-- Other record types or types with discriminants
elsif Is_Record_Type (Ftyp) or else Has_Discriminants (Ptyp) then
-- Build expression with list of equality tests
declare
C : Entity_Id;
X : Node_Id;
@ -6441,16 +6732,18 @@ package body Exp_Attr is
end loop;
Rewrite (N, X);
Analyze_And_Resolve (N, Standard_Boolean);
end;
-- For all other types, result is True (but not static)
-- For all other types, result is True
else
Rewrite (N, New_Occurrence_Of (Standard_Boolean, Loc));
Analyze_And_Resolve (N, Standard_Boolean);
Set_Is_Static_Expression (N, False);
end if;
-- Result is always boolean, but never static
Analyze_And_Resolve (N, Standard_Boolean);
Set_Is_Static_Expression (N, False);
end Valid_Scalars;
-----------

29
gcc/ada/exp_ch3.adb
View File

@ -147,7 +147,7 @@ package body Exp_Ch3 is
-- The resulting operation is a TSS subprogram.
procedure Build_Variant_Record_Equality (Typ : Entity_Id);
-- Create An Equality function for the non-tagged variant record 'Typ'
-- Create An Equality function for the non-tagged variant record Typ
-- and attach it to the TSS list
procedure Check_Stream_Attributes (Typ : Entity_Id);
@ -442,9 +442,7 @@ package body Exp_Ch3 is
Ctyp := Etype (Comp);
if not Is_Array_Type (Ctyp)
or else Number_Dimensions (Ctyp) > 1
then
if not Is_Array_Type (Ctyp) or else Number_Dimensions (Ctyp) > 1 then
goto Continue;
end if;
@ -4279,9 +4277,9 @@ package body Exp_Ch3 is
end if;
end Build_Untagged_Equality;
------------------------------------
-----------------------------------
-- Build_Variant_Record_Equality --
------------------------------------
-----------------------------------
-- Generates:
@ -4289,13 +4287,13 @@ package body Exp_Ch3 is
-- begin
-- -- Compare discriminants
-- if False or else X.D1 /= Y.D1 or else X.D2 /= Y.D2 then
-- if X.D1 /= Y.D1 or else X.D2 /= Y.D2 or else ... then
-- return False;
-- end if;
-- -- Compare components
-- if False or else X.C1 /= Y.C1 or else X.C2 /= Y.C2 then
-- if X.C1 /= Y.C1 or else X.C2 /= Y.C2 or else ... then
-- return False;
-- end if;
@ -4303,12 +4301,12 @@ package body Exp_Ch3 is
-- case X.D1 is
-- when V1 =>
-- if False or else X.C2 /= Y.C2 or else X.C3 /= Y.C3 then
-- if X.C2 /= Y.C2 or else X.C3 /= Y.C3 or else ... then
-- return False;
-- end if;
-- ...
-- when Vn =>
-- if False or else X.Cn /= Y.Cn then
-- if X.Cn /= Y.Cn or else ... then
-- return False;
-- end if;
-- end case;
@ -4323,13 +4321,8 @@ package body Exp_Ch3 is
Make_Defining_Identifier (Loc,
Chars => Make_TSS_Name (Typ, TSS_Composite_Equality));
X : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => Name_X);
Y : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => Name_Y);
X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_X);
Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_Y);
Def : constant Node_Id := Parent (Typ);
Comps : constant Node_Id := Component_List (Type_Definition (Def));
@ -4357,7 +4350,6 @@ package body Exp_Ch3 is
declare
Parent_Eq : constant Entity_Id :=
TSS (Root_Type (Typ), TSS_Composite_Equality);
begin
if Present (Parent_Eq) then
Copy_TSS (Parent_Eq, Typ);
@ -8805,6 +8797,7 @@ package body Exp_Ch3 is
------------------
-- <Make_Eq_If shared components>
-- case X.D1 is
-- when V1 => <Make_Eq_Case> on subcomponents
-- ...

12
gcc/ada/exp_ch4.adb
View File

@ -6164,11 +6164,15 @@ package body Exp_Ch4 is
-- messing especially in the packed case, but more importantly bypasses
-- some problems in handling this peculiar case, for example, the issue
-- of dealing specially with object renamings.
-- This optimization is disabled for CodePeer because it can transform
-- an index-check constraint_error into a range-check constraint_error
-- and CodePeer cares about that distinction.
if Nkind (P) = N_Slice and then not CodePeer_Mode then
if Nkind (P) = N_Slice
-- This optimization is disabled for CodePeer because it can transform
-- an index-check constraint_error into a range-check constraint_error
-- and CodePeer cares about that distinction.
and then not CodePeer_Mode
then
Rewrite (N,
Make_Indexed_Component (Loc,
Prefix => Prefix (P),

10
gcc/ada/gnat_rm.texi
View File

@ -10163,6 +10163,16 @@ be determined at compile time that the prefix of the attribute has no
scalar parts (e.g., if the prefix is of an access type, an interface type,
an undiscriminated task type, or an undiscriminated protected type).
For scalar types, @code{Valid_Scalars} is equivalent to @code{Valid}. The use
of this attribute is not permitted for @code{Unchecked_Union} types for which
in general it is not possible to determine the values of the discriminants.
Note: @code{Valid_Scalars} can generate a lot of code, especially in the case
of a large variant record. If the attribute is called in many places in the
same program applied to objects of the same type, it can reduce program size
to write a function with a single use of the attribute, and then call that
function from multiple places.
@node Attribute VADS_Size
@unnumberedsec Attribute VADS_Size
@cindex @code{Size}, VADS compatibility

2
gcc/ada/gnat_ugn.texi
View File

@ -19972,7 +19972,7 @@ by hand.
@item --omit-sloc
@cindex @option{--omit-sloc} (@command{gnattest})
Supresses comment line containing file name and line number of corresponding
Suppresses comment line containing file name and line number of corresponding
subprograms in test skeletons.
@end table

46
gcc/ada/makeutl.adb
View File

@ -2912,26 +2912,26 @@ package body Makeutl is
is
procedure Do_Insert
(Project : Project_Id;
Tree : Project_Tree_Ref;
Context : Project_Context);
(Project : Project_Id;
Tree : Project_Tree_Ref;
Context : Project_Context);
-- Local procedures must be commented ???
---------------
-- Do_Insert --
---------------
procedure Do_Insert
(Project : Project_Id;
Tree : Project_Tree_Ref;
Context : Project_Context)
(Project : Project_Id;
Tree : Project_Tree_Ref;
Context : Project_Context)
is
Unit_Based : constant Boolean :=
Unique_Compile
or else not Builder_Data (Tree).Closure_Needed;
-- When Unit_Based is True, put in the queue all compilable
-- sources including the unit based (Ada) one. When Unit_Based is
-- False, put the Ada sources only when they are in a library
-- project.
-- When Unit_Based is True, we enqueue all compilable sources
-- including the unit based (Ada) one. When Unit_Based is False,
-- put the Ada sources only when they are in a library project.
Iter : Source_Iterator;
Source : Prj.Source_Id;
@ -2942,9 +2942,7 @@ package body Makeutl is
-- Nothing to do when "-u" was specified and some files were
-- specified on the command line
if Unique_Compile
and then Mains.Number_Of_Mains (Tree) > 0
then
if Unique_Compile and then Mains.Number_Of_Mains (Tree) > 0 then
return;
end if;
@ -2955,16 +2953,13 @@ package body Makeutl is
if Is_Allowed_Language (Source.Language.Name)
and then Is_Compilable (Source)
and then
(All_Projects
or else Is_Extending (Project, Source.Project))
and then (All_Projects
or else Is_Extending (Project, Source.Project))
and then not Source.Locally_Removed
and then Source.Replaced_By = No_Source
and then
(not Source.Project.Externally_Built
or else
(Is_Extending (Project, Source.Project)
and then not Project.Externally_Built))
and then (not Source.Project.Externally_Built
or else (Is_Extending (Project, Source.Project)
and then not Project.Externally_Built))
and then Source.Kind /= Sep
and then Source.Path /= No_Path_Information
then
@ -2988,19 +2983,20 @@ package body Makeutl is
if Source.Unit /= No_Unit_Index
and then
(Source.Project.Library
or else Project.Qualifier = Aggregate_Library
or else Context.In_Aggregate_Lib)
or else Project.Qualifier = Aggregate_Library
or else Context.In_Aggregate_Lib)
and then Source.Project.Standalone_Library /= No
then
-- Check if the unit is in the interface
OK := False;
declare
List : String_List_Id :=
Source.Project.Lib_Interface_ALIs;
List : String_List_Id;
Element : String_Element;
begin
List := Source.Project.Lib_Interface_ALIs;
while List /= Nil_String loop
Element :=
Project_Tree.Shared.String_Elements.Table

21
gcc/ada/sem_attr.adb
View File

@ -6589,13 +6589,24 @@ package body Sem_Attr is
when Attribute_Valid_Scalars =>
Check_E0;
Check_Object_Reference (P);
if not Scalar_Part_Present (P_Type) then
Error_Attr_P ("??attribute % always True, no scalars to check");
end if;
Set_Etype (N, Standard_Boolean);
-- Following checks are only for source types
if Comes_From_Source (N) then
if not Scalar_Part_Present (P_Type) then
Error_Attr_P
("??attribute % always True, no scalars to check");
end if;
-- Not allowed for unchecked union type
if Has_Unchecked_Union (P_Type) then
Error_Attr_P
("attribute % not allowed for Unchecked_Union type");
end if;
end if;
-----------
-- Value --
-----------