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

sem_ch13.adb, [...]: Minor reformatting. 

2010-09-09  Robert Dewar  <dewar@adacore.com>

	* sem_ch13.adb, sem_ch6.adb, exp_ch3.adb: Minor reformatting.

2010-09-09  Robert Dewar  <dewar@adacore.com>

	* einfo.adb (Is_Aggregate_Type): New function.
	* einfo.ads (Aggregate_Kind): New enumeration subtype
	(Is_Aggregate_Type): New function.
	* sem_type.adb (Is_Array_Class_Record_Type): Removed, replaced by
	Is_Aggregate_Typea.

2010-09-09  Robert Dewar  <dewar@adacore.com>

	* exp_ch11.adb, frontend.adb, sem_attr.adb, sem_ch10.adb, sem_ch3.adb,
	sem_ch4.adb, sem_ch9.adb, sem_res.adb: Use Restriction_Check_Needed
	where appropriate.
	* restrict.ads, restrict.adb: Ditto.
	(Restriction_Check_Needed): New function

From-SVN: r164061
This commit is contained in:
Robert Dewar 2010-09-09 09:57:00 +00:00 committed by Arnaud Charlet
parent 61bcf5ca33
commit 7a963087d4
17 changed files with 112 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
gcc/ada/ChangeLog
View File

@ -1,3 +1,23 @@
2010-09-09 Robert Dewar <dewar@adacore.com>
* sem_ch13.adb, sem_ch6.adb, exp_ch3.adb: Minor reformatting.
2010-09-09 Robert Dewar <dewar@adacore.com>
* einfo.adb (Is_Aggregate_Type): New function.
* einfo.ads (Aggregate_Kind): New enumeration subtype
(Is_Aggregate_Type): New function.
* sem_type.adb (Is_Array_Class_Record_Type): Removed, replaced by
Is_Aggregate_Typea.
2010-09-09 Robert Dewar <dewar@adacore.com>
* exp_ch11.adb, frontend.adb, sem_attr.adb, sem_ch10.adb, sem_ch3.adb,
sem_ch4.adb, sem_ch9.adb, sem_res.adb: Use Restriction_Check_Needed
where appropriate.
* restrict.ads, restrict.adb: Ditto.
(Restriction_Check_Needed): New function
2010-09-09 Ed Schonberg <schonberg@adacore.com>
* exp_ch9.ads (Find_Master_Scope): New function, extracted from

5
gcc/ada/einfo.adb
View File

@ -2731,6 +2731,11 @@ package body Einfo is
return Ekind (Id) in Access_Subprogram_Kind;
end Is_Access_Subprogram_Type;
function Is_Aggregate_Type (Id : E) return B is
begin
return Ekind (Id) in Aggregate_Kind;
end Is_Aggregate_Type;
function Is_Array_Type (Id : E) return B is
begin
return Ekind (Id) in Array_Kind;

13
gcc/ada/einfo.ads
View File

@ -4209,6 +4209,17 @@ package Einfo is
E_Access_Protected_Subprogram_Type ..
E_Anonymous_Access_Protected_Subprogram_Type;
subtype Aggregate_Kind is Entity_Kind range
E_Array_Type ..
-- E_Array_Subtype
-- E_String_Type
-- E_String_Subtype
-- E_String_Literal_Subtype
-- E_Class_Wide_Type
-- E_Class_Wide_Subtype
-- E_Record_Type
E_Record_Subtype;
subtype Array_Kind is Entity_Kind range
E_Array_Type ..
-- E_Array_Subtype
@ -6115,6 +6126,7 @@ package Einfo is
function Is_Access_Type (Id : E) return B;
function Is_Access_Protected_Subprogram_Type (Id : E) return B;
function Is_Access_Subprogram_Type (Id : E) return B;
function Is_Aggregate_Type (Id : E) return B;
function Is_Array_Type (Id : E) return B;
function Is_Assignable (Id : E) return B;
function Is_Class_Wide_Type (Id : E) return B;
@ -7125,6 +7137,7 @@ package Einfo is
pragma Inline (Is_Access_Type);
pragma Inline (Is_Access_Protected_Subprogram_Type);
pragma Inline (Is_Access_Subprogram_Type);
pragma Inline (Is_Aggregate_Type);
pragma Inline (Is_Aliased);
pragma Inline (Is_Array_Type);
pragma Inline (Is_Assignable);

2
gcc/ada/exp_ch11.adb
View File

@ -2006,7 +2006,7 @@ package body Exp_Ch11 is
procedure Warn_If_No_Propagation (N : Node_Id) is
begin
if Restriction_Active (No_Exception_Propagation)
if Restriction_Check_Required (No_Exception_Propagation)
and then Warn_On_Non_Local_Exception
then
Warn_No_Exception_Propagation_Active (N);

39
gcc/ada/exp_ch3.adb
View File

@ -142,9 +142,9 @@ package body Exp_Ch3 is
-- are active) can lead to very large blocks that GCC3 handles poorly.
procedure Build_Untagged_Equality (Typ : Entity_Id);
-- AI05-0123: equality on untagged records composes. This procedure
-- build the equality routine for an untagged record that has components
-- of a record type that have user-defined primitive equality operations.
-- AI05-0123: Equality on untagged records composes. This procedure
-- builds the equality routine for an untagged record that has components
-- of a record type that has user-defined primitive equality operations.
-- The resulting operation is a TSS subprogram.
procedure Build_Variant_Record_Equality (Typ : Entity_Id);
@ -3766,9 +3766,9 @@ package body Exp_Ch3 is
Eq_Op : Entity_Id;
function User_Defined_Eq (T : Entity_Id) return Entity_Id;
-- Check whether the type T has a user-defined primitive
-- equality. If true for a component of Typ, we have to
-- build the primitive equality for it.
-- Check whether the type T has a user-defined primitive equality. If so
-- return it, else return Empty. If true for a component of Typ, we have
-- to build the primitive equality for it.
---------------------
-- User_Defined_Eq --
@ -3807,7 +3807,7 @@ package body Exp_Ch3 is
begin
-- If a record component has a primitive equality operation, we must
-- builde the corresponding one for the current type.
-- build the corresponding one for the current type.
Build_Eq := False;
Comp := First_Component (Typ);
@ -3828,7 +3828,11 @@ package body Exp_Ch3 is
Eq_Op := Empty;
while Present (Prim) loop
if Chars (Node (Prim)) = Name_Op_Eq
and then Comes_From_Source (Node (Prim))
and then Comes_From_Source (Node (Prim))
-- Don't we also need to check formal types and return type as in
-- User_Defined_Eq above???
then
Eq_Op := Node (Prim);
Build_Eq := False;
@ -3839,10 +3843,10 @@ package body Exp_Ch3 is
end loop;
-- If the type is derived, inherit the operation, if present, from the
-- parent type. It may have been declared after the type derivation.
-- If the parent type itself is derived, it may have inherited an
-- operation that has itself been overridden, so update its alias
-- and related flags. Ditto for inequality.
-- parent type. It may have been declared after the type derivation. If
-- the parent type itself is derived, it may have inherited an operation
-- that has itself been overridden, so update its alias and related
-- flags. Ditto for inequality.
if No (Eq_Op) and then Is_Derived_Type (Typ) then
Prim := First_Elmt (Collect_Primitive_Operations (Etype (Typ)));
@ -3877,13 +3881,12 @@ package body Exp_Ch3 is
end loop;
end if;
-- If not inherited and not user-defined, build body as for a type
-- with tagged components.
-- If not inherited and not user-defined, build body as for a type with
-- tagged components.
if Build_Eq then
Decl :=
Make_Eq_Body
(Typ, Make_TSS_Name (Typ, TSS_Composite_Equality));
Make_Eq_Body (Typ, Make_TSS_Name (Typ, TSS_Composite_Equality));
Op := Defining_Entity (Decl);
Set_TSS (Typ, Op);
Set_Is_Pure (Op);
@ -7824,8 +7827,8 @@ package body Exp_Ch3 is
Comps := Component_List (Typ_Def);
end if;
Variant_Case := Present (Comps)
and then Present (Variant_Part (Comps));
Variant_Case :=
Present (Comps) and then Present (Variant_Part (Comps));
end if;
if Variant_Case then

2
gcc/ada/frontend.adb
View File

@ -290,7 +290,7 @@ begin
-- explicit switch turning off Warn_On_Non_Local_Exception, then turn on
-- this warning by default if we have encountered an exception handler.
if Restriction_Active (No_Exception_Propagation)
if Restriction_Check_Required (No_Exception_Propagation)
and then not No_Warn_On_Non_Local_Exception
and then Exception_Handler_Encountered
then

19
gcc/ada/restrict.adb
View File

@ -144,8 +144,8 @@ package body Restrict is
-- Start of processing for Check_Obsolescent_2005_Entity
begin
if Ada_Version >= Ada_2005
and then Restriction_Active (No_Obsolescent_Features)
if Restriction_Check_Required (No_Obsolescent_Features)
and then Ada_Version >= Ada_2005
and then Chars_Is (Scope (E), "handling")
and then Chars_Is (Scope (Scope (E)), "characters")
and then Chars_Is (Scope (Scope (Scope (E))), "ada")
@ -298,8 +298,8 @@ package body Restrict is
-- Start of processing for Check_Restriction
begin
-- In CodePeer mode, we do not want to check for any restriction, or
-- set additional restrictions than those already set in gnat1drv.adb
-- In CodePeer mode, we do not want to check for any restriction, or set
-- additional restrictions other than those already set in gnat1drv.adb
-- so that we have consistency between each compilation.
if CodePeer_Mode then
@ -403,7 +403,7 @@ package body Restrict is
procedure Check_Wide_Character_Restriction (E : Entity_Id; N : Node_Id) is
begin
if Restriction_Active (No_Wide_Characters)
if Restriction_Check_Required (No_Wide_Characters)
and then Comes_From_Source (N)
then
declare
@ -586,6 +586,15 @@ package body Restrict is
return Restrictions.Set (R) and then not Restriction_Warnings (R);
end Restriction_Active;
--------------------------------
-- Restriction_Check_Required --
--------------------------------
function Restriction_Check_Required (R : All_Restrictions) return Boolean is
begin
return Restrictions.Set (R);
end Restriction_Check_Required;
---------------------
-- Restriction_Msg --
---------------------

14
gcc/ada/restrict.ads
View File

@ -292,7 +292,19 @@ package Restrict is
-- used where the compiled code depends on whether the restriction is
-- active. Always use Check_Restriction to record a violation. Note that
-- this returns False if we only have a Restriction_Warnings set, since
-- restriction warnings should never affect generated code.
-- restriction warnings should never affect generated code. If you want
-- to know if a call to Check_Restriction is needed then use the function
-- Restriction_Check_Required instead.
function Restriction_Check_Required (R : All_Restrictions) return Boolean;
pragma Inline (Restriction_Check_Required);
-- Determines if either a Restriction_Warnings or Restrictions pragma has
-- been given for the specified restriction. If true, then a subsequent
-- call to Check_Restriction is required if the restriction is violated.
-- This must not be used to guard code generation that depends on whether
-- a restriction is active (see Restriction_Active above). Typically it
-- is used to avoid complex code to determine if a restriction is violated,
-- executing this code only if needed.
function Restricted_Profile return Boolean;
-- Tests if set of restrictions corresponding to Profile (Restricted) is

2
gcc/ada/sem_attr.adb
View File

@ -2549,7 +2549,7 @@ package body Sem_Attr is
-- 2005. Note that we can't test Is_Tagged_Type here on P_Type, since
-- this flag gets set by Find_Type in this situation.
if Restriction_Active (No_Obsolescent_Features)
if Restriction_Check_Required (No_Obsolescent_Features)
and then Ada_Version >= Ada_2005
and then Ekind (P_Type) = E_Incomplete_Type
then

2
gcc/ada/sem_ch10.adb
View File

@ -2325,7 +2325,7 @@ package body Sem_Ch10 is
-- Note: this is not quite right if the user defines one of these units
-- himself, but that's a marginal case, and fixing it is hard ???
if Restriction_Active (No_Obsolescent_Features) then
if Restriction_Check_Required (No_Obsolescent_Features) then
declare
F : constant File_Name_Type :=
Unit_File_Name (Get_Source_Unit (U));

8
gcc/ada/sem_ch13.adb
View File

@ -2360,8 +2360,8 @@ package body Sem_Ch13 is
function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id;
-- Ada 2005 (AI-251): Makes specs for null procedures associated with
-- null procedures inherited from interface types that have not been
-- overridden. Only one null procedure will be created for a given
-- set of inherited null procedures with homographic profiles.
-- overridden. Only one null procedure will be created for a given set
-- of inherited null procedures with homographic profiles.
-------------------------------
-- Make_Null_Procedure_Specs --
@ -2419,8 +2419,8 @@ package body Sem_Ch13 is
-- of the interface type)
if Is_Controlling_Formal (Formal) then
if Nkind (Parameter_Type (Parent (Formal)))
= N_Identifier
if Nkind (Parameter_Type (Parent (Formal))) =
N_Identifier
then
Set_Parameter_Type (New_Param_Spec,
New_Occurrence_Of (Tag_Typ, Loc));

4
gcc/ada/sem_ch3.adb
View File

@ -2779,7 +2779,7 @@ package body Sem_Ch3 is
-- 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 Restriction_Check_Required (No_Streams) then
if Has_Stream (T) then
Check_Restriction (No_Streams, N);
end if;
@ -13659,7 +13659,7 @@ package body Sem_Ch3 is
-- Check violation of No_Wide_Characters
if Restriction_Active (No_Wide_Characters) then
if Restriction_Check_Required (No_Wide_Characters) then
Get_Name_String (Chars (L));
if Name_Len >= 3 and then Name_Buffer (1 .. 2) = "QW" then

2
gcc/ada/sem_ch4.adb
View File

@ -617,7 +617,7 @@ package body Sem_Ch4 is
-- 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 Restriction_Check_Required (No_Streams) then
if Has_Stream (Designated_Type (Acc_Type)) then
Check_Restriction (No_Streams, N);
end if;

4
gcc/ada/sem_ch6.adb
View File

@ -4037,9 +4037,7 @@ package body Sem_Ch6 is
Error_Msg_Name_2 := Get_Convention_Name (Convention (Op));
Error_Msg_Sloc := Sloc (Op);
if Comes_From_Source (Op)
or else No (Alias (Op))
then
if Comes_From_Source (Op) or else No (Alias (Op)) then
if not Is_Overriding_Operation (Op) then
Error_Msg_N ("\\primitive % defined #", Typ);
else

22
gcc/ada/sem_ch9.adb
View File

@ -1182,9 +1182,9 @@ package body Sem_Ch9 is
-- and the No_Local_Protected_Objects restriction applies, issue a
-- warning that objects of the type will violate the restriction.
if not Is_Library_Level_Entity (T)
if Restriction_Check_Required (No_Local_Protected_Objects)
and then not Is_Library_Level_Entity (T)
and then Comes_From_Source (T)
and then Restrictions.Set (No_Local_Protected_Objects)
then
Error_Msg_Sloc := Restrictions_Loc (No_Local_Protected_Objects);
@ -1995,9 +1995,9 @@ package body Sem_Ch9 is
-- No_Task_Hierarchy restriction applies, issue a warning that objects
-- of the type will violate the restriction.
if not Is_Library_Level_Entity (T)
if Restriction_Check_Required (No_Task_Hierarchy)
and then not Is_Library_Level_Entity (T)
and then Comes_From_Source (T)
and then Restrictions.Set (No_Task_Hierarchy)
then
Error_Msg_Sloc := Restrictions_Loc (No_Task_Hierarchy);
@ -2193,18 +2193,10 @@ package body Sem_Ch9 is
-- Entry family with non-static bounds
else
-- If restriction is set, then this is an error
-- Record an unknown count restriction, and if the
-- restriction is active, post a message or warning.
if Restrictions.Set (R) then
Error_Msg_N
("static subtype required by Restriction pragma",
DSD);
-- Otherwise we record an unknown count restriction
else
Check_Restriction (R, D);
end if;
Check_Restriction (R, D);
end if;
end;
end if;

2
gcc/ada/sem_res.adb
View File

@ -4759,7 +4759,7 @@ package body Sem_Res is
-- violated if either operand can be negative for mod, or for rem
-- if both operands can be negative.
if Restrictions.Set (No_Implicit_Conditionals)
if Restriction_Check_Required (No_Implicit_Conditionals)
and then Nkind_In (N, N_Op_Rem, N_Op_Mod)
then
declare

33
gcc/ada/sem_type.adb
View File

@ -184,18 +184,6 @@ package body Sem_Type is
-- Interp_Has_Abstract_Op. Determine whether an overloaded node has an
-- abstract interpretation which yields type Typ.
function Is_Array_Class_Record_Type (E : Entity_Id) return Boolean;
-- This function tests if entity E is in Array_Kind, or Class_Wide_Kind,
-- or is E_Record_Type or E_Record_Subtype, and returns True for these
-- cases, and False for all others. Note that other record entity kinds
-- such as E_Record_Type_With_Private return False.
--
-- This is a bit of an odd category, maybe it is wrong or a better name
-- could be found for the class of entities being tested. The history
-- is that this used to be done with an explicit range test for the range
-- E_Array_Type .. E_Record_Subtype, which was itself suspicious and is
-- now prohibited by the -gnatyE style check ???
procedure New_Interps (N : Node_Id);
-- Initialize collection of interpretations for the given node, which is
-- either an overloaded entity, or an operation whose arguments have
@ -912,7 +900,7 @@ package body Sem_Type is
-- An aggregate is compatible with an array or record type
elsif T2 = Any_Composite
and then Is_Array_Class_Record_Type (T1)
and then Is_Aggregate_Type (T1)
then
return True;
@ -2632,6 +2620,9 @@ package body Sem_Type is
else
Par := Etype (Par);
end if;
-- For all other cases return False, not an Ancestor
else
return False;
end if;
@ -2639,18 +2630,6 @@ package body Sem_Type is
end if;
end Is_Ancestor;
--------------------------------
-- Is_Array_Class_Record_Type --
--------------------------------
function Is_Array_Class_Record_Type (E : Entity_Id) return Boolean is
begin
return Is_Array_Type (E)
or else Is_Class_Wide_Type (E)
or else Ekind (E) = E_Record_Type
or else Ekind (E) = E_Record_Subtype;
end Is_Array_Class_Record_Type;
---------------------------
-- Is_Invisible_Operator --
---------------------------
@ -3069,12 +3048,12 @@ package body Sem_Type is
return T1;
elsif T2 = Any_Composite
and then Is_Array_Class_Record_Type (T1)
and then Is_Aggregate_Type (T1)
then
return T1;
elsif T1 = Any_Composite
and then Is_Array_Class_Record_Type (T2)
and then Is_Aggregate_Type (T2)
then
return T2;