git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

2012-04-02 Robert Dewar <dewar@adacore.com> 

* einfo.adb (First_Component_Or_Discriminant) Now applies to
	all types with discriminants, not just records.
	* exp_attr.adb (Expand_N_Attribute): Add Scalar_Values handling
	for arrays, scalars and non-variant records.
	* sem_attr.adb (Analyze_Attribute): Handle Valid_Scalars
	* sem_attr.ads (Valid_Scalars): Update description
	* sem_util.ads, sem_util.adb (No_Scalar_Parts): New function.

From-SVN: r186069
This commit is contained in:
Robert Dewar 2012-04-02 09:14:47 +00:00 committed by Arnaud Charlet
parent cdc30df3e2
commit 99fc068ee8
7 changed files with 296 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
gcc/ada/ChangeLog
View File

@ -1,3 +1,13 @@
2012-04-02 Robert Dewar <dewar@adacore.com>
* einfo.adb (First_Component_Or_Discriminant) Now applies to
all types with discriminants, not just records.
* exp_attr.adb (Expand_N_Attribute): Add Scalar_Values handling
for arrays, scalars and non-variant records.
* sem_attr.adb (Analyze_Attribute): Handle Valid_Scalars
* sem_attr.ads (Valid_Scalars): Update description
* sem_util.ads, sem_util.adb (No_Scalar_Parts): New function.
2012-03-31 Eric Botcazou <ebotcazou@adacore.com>
Revert

4
gcc/ada/einfo.adb
View File

@ -5880,7 +5880,9 @@ package body Einfo is
begin
pragma Assert
(Is_Record_Type (Id) or else Is_Incomplete_Or_Private_Type (Id));
(Is_Record_Type (Id)
or else Is_Incomplete_Or_Private_Type (Id)
or else Has_Discriminants (Id));
Comp_Id := First_Entity (Id);
while Present (Comp_Id) loop

234
gcc/ada/exp_attr.adb
View File

@ -76,6 +76,14 @@ package body Exp_Attr is
-- Local Subprograms --
-----------------------
function Build_Array_VS_Func
(A_Type : Entity_Id;
Nod : Node_Id) return Entity_Id;
-- Build function to test Valid_Scalars for array 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;
@ -174,6 +182,149 @@ package body Exp_Attr is
-- expansion. Typically used for rounding and truncation attributes that
-- appear directly inside a conversion to integer.
-------------------------
-- Build_Array_VS_Func --
-------------------------
function Build_Array_VS_Func
(A_Type : Entity_Id;
Nod : Node_Id) return Entity_Id
is
Loc : constant Source_Ptr := Sloc (Nod);
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;
-- Create one statement to test validity of one component designated by
-- a full set of indexes. Returns statement list containing test.
function Test_One_Dimension (N : Int) return List_Id;
-- Create loop to test one dimension of the array. The single statement
-- in the loop body tests the inner dimensions if any, or else the
-- single component. Note that this procedure is called recursively,
-- with N being the dimension to be initialized. A call with N greater
-- than the number of dimensions simply generates the component test,
-- terminating the recursion. Returns statement list containing tests.
--------------------
-- Test_Component --
--------------------
function Test_Component return List_Id is
Comp : Node_Id;
Anam : Name_Id;
begin
Comp :=
Make_Indexed_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uA),
Expressions => Index_List);
if Is_Scalar_Type (Comp_Type) then
Anam := Name_Valid;
else
Anam := Name_Valid_Scalars;
end if;
return New_List (
Make_If_Statement (Loc,
Condition =>
Make_Op_Not (Loc,
Right_Opnd =>
Make_Attribute_Reference (Loc,
Attribute_Name => Anam,
Prefix => Comp)),
Then_Statements => New_List (
Make_Simple_Return_Statement (Loc,
Expression => New_Occurrence_Of (Standard_False, Loc)))));
end Test_Component;
------------------------
-- Test_One_Dimension --
------------------------
function Test_One_Dimension (N : Int) return List_Id is
Index : Entity_Id;
begin
-- If all dimensions dealt with, we simply test the component
if N > Number_Dimensions (A_Type) then
return Test_Component;
-- Here we generate the required loop
else
Index :=
Make_Defining_Identifier (Loc, New_External_Name ('J', N));
Append (New_Reference_To (Index, Loc), Index_List);
return New_List (
Make_Implicit_Loop_Statement (Nod,
Identifier => Empty,
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
Defining_Identifier => Index,
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, Name_uA),
Attribute_Name => Name_Range,
Expressions => New_List (
Make_Integer_Literal (Loc, N))))),
Statements => Test_One_Dimension (N + 1)),
Make_Simple_Return_Statement (Loc,
Expression => New_Occurrence_Of (Standard_True, Loc)));
end if;
end Test_One_Dimension;
-- Start of processing for Build_Array_VS_Func
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)
Formals := New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uA),
In_Present => True,
Out_Present => False,
Parameter_Type => New_Reference_To (A_Type, Loc)));
-- Build body
Set_Ekind (Func_Id, E_Function);
Set_Is_Internal (Func_Id);
Insert_Action (Nod,
Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => Func_Id,
Parameter_Specifications => Formals,
Result_Definition =>
New_Occurrence_Of (Standard_Boolean, Loc)),
Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Body_Stmts)));
if not Debug_Generated_Code then
Set_Debug_Info_Off (Func_Id);
end if;
return Func_Id;
end Build_Array_VS_Func;
----------------------------------
-- Compile_Stream_Body_In_Scope --
----------------------------------
@ -5373,8 +5524,89 @@ package body Exp_Attr is
-------------------
when Attribute_Valid_Scalars => Valid_Scalars : declare
Ftyp : Entity_Id;
begin
raise Program_Error;
if Present (Underlying_Type (Ptyp)) then
Ftyp := Underlying_Type (Ptyp);
else
Ftyp := Ptyp;
end if;
-- For scalar types, Valid_Scalars is the same as Valid
if 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.
-- We only do this for arrays whose component type needs checking
elsif Is_Array_Type (Ftyp)
and then not No_Scalar_Parts (Component_Type (Ftyp))
then
Rewrite (N,
Make_Function_Call (Loc,
Name =>
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 build a big conditional expression, applying
-- Valid or Valid_Scalars as appropriate to all relevant components.
elsif (Is_Record_Type (Ptyp) or else Has_Discriminants (Ptyp))
and then not No_Scalar_Parts (Ptyp)
then
declare
C : Entity_Id;
X : Node_Id;
A : Name_Id;
begin
X := New_Occurrence_Of (Standard_True, Loc);
C := First_Component_Or_Discriminant (Ptyp);
while Present (C) loop
if No_Scalar_Parts (Etype (C)) then
goto Continue;
elsif Is_Scalar_Type (Etype (C)) then
A := Name_Valid;
else
A := Name_Valid_Scalars;
end if;
X :=
Make_And_Then (Loc,
Left_Opnd => X,
Right_Opnd =>
Make_Attribute_Reference (Loc,
Attribute_Name => A,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Duplicate_Subexpr (Pref, Name_Req => True),
Selector_Name =>
New_Occurrence_Of (C, Loc))));
<<Continue>>
Next_Component_Or_Discriminant (C);
end loop;
Rewrite (N, X);
Analyze_And_Resolve (N, Standard_Boolean);
end;
-- For all other types, result is True (but not static)
else
Rewrite (N, New_Occurrence_Of (Standard_Boolean, Loc));
Analyze_And_Resolve (N, Standard_Boolean);
Set_Is_Static_Expression (N, False);
end if;
end Valid_Scalars;
-----------

11
gcc/ada/sem_attr.adb
View File

@ -323,7 +323,7 @@ package body Sem_Attr is
-- type or a private type for which no full view has been given.
procedure Check_Object_Reference (P : Node_Id);
-- Check that P (the prefix of the attribute) is an object reference
-- Check that P is an object reference
procedure Check_Program_Unit;
-- Verify that prefix of attribute N is a program unit
@ -5202,8 +5202,13 @@ package body Sem_Attr is
when Attribute_Valid_Scalars =>
Check_E0;
Check_Type;
-- More stuff TBD ???
Check_Object_Reference (P);
if No_Scalar_Parts (P_Type) then
Error_Attr_P ("?attribute % always True, no scalars to check");
end if;
Set_Etype (N, Standard_Boolean);
-----------
-- Value --

12
gcc/ada/sem_attr.ads
View File

@ -560,12 +560,18 @@ package Sem_Attr is
-- For a scalar type, the result is the same as obj'Valid
--
-- For an array object, the result is True if the result of applying
-- Valid_Scalars to every component is True.
-- Valid_Scalars to every component is True. For an empty array the
-- result is True.
--
-- For a record object, the result is True if the result of applying
-- Valid_Scalars to every component is True. For class-wide types,
-- only the components of the base type are checked. For variant
-- records, only the components actually present are checked.
-- records, only the components actually present are checked. The
-- discriminants, if any, are also checked. If there are no components
-- or discriminants, the result is True.
--
-- For any other type that has discriminants, the result is True if
-- the result of applying Valid_Scalars to each discriminant is True.
--
-- For all other types, the result is always True
--
@ -574,7 +580,7 @@ package Sem_Attr is
-- type, or in the composite case if no scalar subcomponents exist. For
-- a variant record, the warning is given only if none of the variants
-- have scalar subcomponents. In addition, the warning is suppressed
-- for private types, or generic types in an instance.
-- for private types, or generic formal types in an instance.
----------------
-- Value_Size --

28
gcc/ada/sem_util.adb
View File

@ -10499,6 +10499,34 @@ package body Sem_Util is
Actual_Id := Next_Actual (Actual_Id);
end Next_Actual;
---------------------
-- No_Scalar_Parts --
---------------------
function No_Scalar_Parts (T : Entity_Id) return Boolean is
C : Entity_Id;
begin
if Is_Scalar_Type (T) then
return False;
elsif Is_Array_Type (T) then
return No_Scalar_Parts (Component_Type (T));
elsif Is_Record_Type (T) or else Has_Discriminants (T) then
C := First_Component_Or_Discriminant (T);
while Present (C) loop
if not No_Scalar_Parts (Etype (C)) then
return False;
else
Next_Component_Or_Discriminant (C);
end if;
end loop;
end if;
return True;
end No_Scalar_Parts;
-----------------------
-- Normalize_Actuals --
-----------------------

5
gcc/ada/sem_util.ads
View File

@ -1221,6 +1221,11 @@ package Sem_Util is
-- Note that the result produced is always an expression, not a parameter
-- association node, even if named notation was used.
function No_Scalar_Parts (T : Entity_Id) return Boolean;
-- Tests if type T can be determined at compile time to have no scalar
-- parts in the sense of the Valid_Scalars attribute. Returns True if
-- this is the case, meaning that the result of Valid_Scalars is True.
procedure Normalize_Actuals
(N : Node_Id;
S : Entity_Id;