mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-15 09:00:29 +08:00
Code Issues Packages Projects Releases Wiki Activity

gnat_rm.texi: Document pragma Unevaluated_Use_Of_Old.

Browse Source 
2014-07-29  Robert Dewar  <dewar@adacore.com>

	* gnat_rm.texi: Document pragma Unevaluated_Use_Of_Old.
	* opt.adb: Handle Uneval_Old.
	* opt.ads (Uneval_Old, Uneval_Old_Config): New variables.
	* par-prag.adb: Add dummy entry for pragma Unevaluated_Use_Of_Old.
	* sem.ads (Save_Uneval_Old): New field in Scope_Stack_Entry.
	* sem_attr.adb (Uneval_Old_Msg): New procedure.
	* sem_ch8.adb (Push_Scope): Save Uneval_Old.
	(Pop_Scope): Restore Uneval_Old.
	* sem_prag.adb (Analyze_Pragma, case Unevaluated_Use_Of_Old):
	Implemented.
	* snames.ads-tmpl: Add entries for pragma Unevaluated_Use_Of_Old
	Add entries for Name_Warn, Name_Allow.

From-SVN: r213160
This commit is contained in:
Robert Dewar 2014-07-29 13:00:08 +00:00 committed by Arnaud Charlet
parent edab608853
commit 96e90ac1ec
19 changed files with 251 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
gcc/ada/ChangeLog
View File

@ -1,3 +1,18 @@
2014-07-29 Robert Dewar <dewar@adacore.com>
* gnat_rm.texi: Document pragma Unevaluated_Use_Of_Old.
* opt.adb: Handle Uneval_Old.
* opt.ads (Uneval_Old, Uneval_Old_Config): New variables.
* par-prag.adb: Add dummy entry for pragma Unevaluated_Use_Of_Old.
* sem.ads (Save_Uneval_Old): New field in Scope_Stack_Entry.
* sem_attr.adb (Uneval_Old_Msg): New procedure.
* sem_ch8.adb (Push_Scope): Save Uneval_Old.
(Pop_Scope): Restore Uneval_Old.
* sem_prag.adb (Analyze_Pragma, case Unevaluated_Use_Of_Old):
Implemented.
* snames.ads-tmpl: Add entries for pragma Unevaluated_Use_Of_Old
Add entries for Name_Warn, Name_Allow.
2014-07-29 Robert Dewar <dewar@adacore.com>
* sem_aggr.adb (Resolve_Array_Aggregate): Change Is_Static_Range

20
gcc/ada/checks.adb
View File

@ -5973,13 +5973,18 @@ package body Checks is
-- cases are like this. Notably conversions can involve two types.
if Source_Base_Type = Target_Base_Type then
-- Insert the explicit range check. Note that we suppress checks for
-- this code, since we don't want a recursive range check popping up.
Insert_Action (N,
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Not_In (Loc,
Left_Opnd => Duplicate_Subexpr (N),
Right_Opnd => New_Occurrence_Of (Target_Type, Loc)),
Reason => Reason));
Reason => Reason),
Suppress => All_Checks);
-- Next test for the case where the target type is within the bounds
-- of the base type of the source type, since in this case we can
@ -5999,6 +6004,10 @@ package body Checks is
-- itself does not require a check.
elsif In_Subrange_Of (Target_Type, Source_Base_Type) then
-- Insert the explicit range check. Note that we suppress checks for
-- this code, since we don't want a recursive range check popping up.
Insert_Action (N,
Make_Raise_Constraint_Error (Loc,
Condition =>
@ -6020,7 +6029,8 @@ package body Checks is
Prefix =>
New_Occurrence_Of (Target_Type, Loc),
Attribute_Name => Name_Last)))),
Reason => Reason));
Reason => Reason),
Suppress => All_Checks);
-- Note that at this stage we now that the Target_Base_Type is not in
-- the range of the Source_Base_Type (since even the Target_Type itself
@ -6041,6 +6051,9 @@ package body Checks is
-- Then the conversion itself is replaced by an occurrence of Tnn
-- Insert the explicit range check. Note that we suppress checks for
-- this code, since we don't want a recursive range check popping up.
declare
Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N);
@ -6062,7 +6075,8 @@ package body Checks is
Left_Opnd => New_Occurrence_Of (Tnn, Loc),
Right_Opnd => New_Occurrence_Of (Target_Type, Loc)),
Reason => Reason)));
Reason => Reason)),
Suppress => All_Checks);
Rewrite (N, New_Occurrence_Of (Tnn, Loc));

14
gcc/ada/einfo.adb
View File

@ -562,11 +562,12 @@ package body Einfo is
-- Has_Static_Predicate Flag269
-- Stores_Attribute_Old_Prefix Flag270
-- (Has_Protected) Flag271
-- (unused) Flag1
-- (unused) Flag2
-- (unused) Flag3
-- (unused) Flag271
-- (unused) Flag272
-- (unused) Flag273
-- (unused) Flag274
@ -1643,6 +1644,11 @@ package body Einfo is
return Flag155 (Id);
end Has_Private_Declaration;
function Has_Protected (Id : E) return B is
begin
return Flag271 (Id);
end Has_Protected;
function Has_Qualified_Name (Id : E) return B is
begin
return Flag161 (Id);
@ -4372,6 +4378,11 @@ package body Einfo is
Set_Flag155 (Id, V);
end Set_Has_Private_Declaration;
procedure Set_Has_Protected (Id : E; V : B := True) is
begin
Set_Flag271 (Id, V);
end Set_Has_Protected;
procedure Set_Has_Qualified_Name (Id : E; V : B := True) is
begin
Set_Flag161 (Id, V);
@ -8252,6 +8263,7 @@ package body Einfo is
W ("Has_Primitive_Operations", Flag120 (Id));
W ("Has_Private_Ancestor", Flag151 (Id));
W ("Has_Private_Declaration", Flag155 (Id));
W ("Has_Protected", Flag271 (Id));
W ("Has_Qualified_Name", Flag161 (Id));
W ("Has_RACW", Flag214 (Id));
W ("Has_Record_Rep_Clause", Flag65 (Id));

13
gcc/ada/einfo.ads
View File

@ -1808,6 +1808,14 @@ package Einfo is
-- indicate if a full type declaration is a completion. Used for semantic
-- checks in E.4(18) and elsewhere.
-- Has_Protected (Flag271) [base type only]
-- Defined in all type entities. Set on protected types themselves, and
-- also (recursively) on any composite type which has a component for
-- which Has_Protected is set. The meaning is that an allocator for
-- or declaration of such an object must create the required protected
-- objects. Note: the flag is not set on access types, even if they
-- designate an object that Has_Protected.
-- Has_Qualified_Name (Flag161)
-- Defined in all entities. Set if the name in the Chars field has
-- been replaced by its qualified name, as used for debug output. See
@ -5203,6 +5211,7 @@ package Einfo is
-- Has_Pragma_Unreferenced_Objects (Flag212)
-- Has_Predicates (Flag250)
-- Has_Primitive_Operations (Flag120) (base type only)
-- Has_Protected (Flag271) (base type only)
-- Has_Size_Clause (Flag29)
-- Has_Specified_Layout (Flag100) (base type only)
-- Has_Specified_Stream_Input (Flag190)
@ -6551,6 +6560,7 @@ package Einfo is
function Has_Primitive_Operations (Id : E) return B;
function Has_Private_Ancestor (Id : E) return B;
function Has_Private_Declaration (Id : E) return B;
function Has_Protected (Id : E) return B;
function Has_Qualified_Name (Id : E) return B;
function Has_RACW (Id : E) return B;
function Has_Record_Rep_Clause (Id : E) return B;
@ -7179,6 +7189,7 @@ package Einfo is
procedure Set_Has_Primitive_Operations (Id : E; V : B := True);
procedure Set_Has_Private_Ancestor (Id : E; V : B := True);
procedure Set_Has_Private_Declaration (Id : E; V : B := True);
procedure Set_Has_Protected (Id : E; V : B := True);
procedure Set_Has_Qualified_Name (Id : E; V : B := True);
procedure Set_Has_RACW (Id : E; V : B := True);
procedure Set_Has_Record_Rep_Clause (Id : E; V : B := True);
@ -7920,6 +7931,7 @@ package Einfo is
pragma Inline (Has_Primitive_Operations);
pragma Inline (Has_Private_Ancestor);
pragma Inline (Has_Private_Declaration);
pragma Inline (Has_Protected);
pragma Inline (Has_Qualified_Name);
pragma Inline (Has_RACW);
pragma Inline (Has_Record_Rep_Clause);
@ -8395,6 +8407,7 @@ package Einfo is
pragma Inline (Set_Has_Primitive_Operations);
pragma Inline (Set_Has_Private_Ancestor);
pragma Inline (Set_Has_Private_Declaration);
pragma Inline (Set_Has_Protected);
pragma Inline (Set_Has_Qualified_Name);
pragma Inline (Set_Has_RACW);
pragma Inline (Set_Has_Record_Rep_Clause);

2
gcc/ada/errout.ads
View File

@ -836,7 +836,7 @@ package Errout is
procedure Remove_Warning_Messages (N : Node_Id);
-- Remove any warning messages corresponding to the Sloc of N or any
-- of its descendent nodes. No effect if no such warnings. Note that
-- style messages (identified by the fact that they start with "(style)"
-- style messages (identified by the fact that they start with "(style)")
-- are not removed by this call. Basically the idea behind this procedure
-- is to remove warnings about execution conditions from known dead code.

29
gcc/ada/exp_ch3.adb
View File

@ -6160,12 +6160,15 @@ package body Exp_Ch3 is
-- If the component contains tasks, so does the array type. This may
-- not be indicated in the array type because the component may have
-- been a private type at the point of definition. Same if component
-- type is controlled.
-- type is controlled or contains protected objects.
Set_Has_Task (Base, Has_Task (Comp_Typ));
Set_Has_Controlled_Component (Base,
Has_Controlled_Component (Comp_Typ)
or else Is_Controlled (Comp_Typ));
Set_Has_Task (Base, Has_Task (Comp_Typ));
Set_Has_Protected (Base, Has_Protected (Comp_Typ));
Set_Has_Controlled_Component
(Base, Has_Controlled_Component
(Comp_Typ)
or else
Is_Controlled (Comp_Typ));
if No (Init_Proc (Base)) then
@ -6719,9 +6722,9 @@ package body Exp_Ch3 is
Check_Stream_Attributes (Def_Id);
end if;
-- Update task and controlled component flags, because some of the
-- component types may have been private at the point of the record
-- declaration. Detect anonymous access-to-controlled components.
-- Update task, protected, and controlled component flags, because some
-- of the component types may have been private at the point of the
-- record declaration. Detect anonymous access-to-controlled components.
Has_AACC := False;
@ -6731,20 +6734,26 @@ package body Exp_Ch3 is
if Has_Task (Comp_Typ) then
Set_Has_Task (Def_Id);
end if;
if Has_Protected (Comp_Typ) then
Set_Has_Protected (Def_Id);
end if;
-- Do not set Has_Controlled_Component on a class-wide equivalent
-- type. See Make_CW_Equivalent_Type.
elsif not Is_Class_Wide_Equivalent_Type (Def_Id)
if not Is_Class_Wide_Equivalent_Type (Def_Id)
and then (Has_Controlled_Component (Comp_Typ)
or else (Chars (Comp) /= Name_uParent
and then Is_Controlled (Comp_Typ)))
then
Set_Has_Controlled_Component (Def_Id);
end if;
-- Non-self-referential anonymous access-to-controlled component
elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type
if Ekind (Comp_Typ) = E_Anonymous_Access_Type
and then Needs_Finalization (Designated_Type (Comp_Typ))
and then Designated_Type (Comp_Typ) /= Def_Id
then

55
gcc/ada/gnat_rm.texi
View File

@ -270,6 +270,7 @@ Implementation Defined Pragmas
* Pragma Type_Invariant::
* Pragma Type_Invariant_Class::
* Pragma Unchecked_Union::
* Pragma Unevaluated_Use_Of_Old::
* Pragma Unimplemented_Unit::
* Pragma Universal_Aliasing ::
* Pragma Universal_Data::
@ -1119,6 +1120,7 @@ consideration, the use of these pragmas should be minimized.
* Pragma Type_Invariant::
* Pragma Type_Invariant_Class::
* Pragma Unchecked_Union::
* Pragma Unevaluated_Use_Of_Old::
* Pragma Unimplemented_Unit::
* Pragma Universal_Aliasing ::
* Pragma Universal_Data::
@ -7242,6 +7244,59 @@ pragma, making it language defined, and GNAT fully implements this extended
version in all language modes (Ada 83, Ada 95, and Ada 2005). For full
details, consult the Ada 2012 Reference Manual, section B.3.3.
@node Pragma Unevaluated_Use_Of_Old
@unnumberedsec Pragma Unevaluated_Use_Of_Old
@cindex Attribute Old
@cindex Attribute Loop_Entry
@cindex Unevaluated_Use_Of_Old
@findex Unevaluated_Use_Of_Old
@noindent
Syntax:
@smallexample @c ada
pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
@end smallexample
@noindent
This pragma controls the processing of attributes Old and Loop_Entry.
If either of these attributes is used in a potentially unevaluated
expression (e.g. the then or else parts of an if expression), then
normally this usage is considered illegal if the prefix of the attribute
is other than an entity name. The language requires this
behavior for Old, and GNAT copies the same rule for Loop_Entry.
The reason for this rule is that otherwise, we can have a situation
where we save the Old value, and this results in an exception, even
though we might not evaluate the attribute. Consider this example:
@smallexample @c ada
package UnevalOld is
K : Character;
procedure U (A : String; C : Boolean) -- ERROR
with Post => (if C then A(1)'Old = K else True);
end;
@end smallexample
@noindent
If procedure U is called with a string with a lower bound of 2, and
C false, then an exception would be raised trying to evaluate A(1)
on entry even though the value would not be actually used.
Although the rule guarantees against this possibility, it is sometimes
too restrictive. For example if we know that the string has a lower
bound of 1, then we will never raise an exception.
The pragma @code{Unevaluated_Use_Of_Old} can be
used to modify this behavior. If the argument is @code{Error} then an
error is given (this is the default RM behavior). If the argument is
@code{Warn} then the usage is allowed as legal but with a warning
that an exception might be raised. If the argument is @code{Allow}
then the usage is allowed as legal without generating a warning.
This pragma may appear as a configuration pragma, or in a declarative
part or package specification. In the latter case it applies to
uses up to the end of the corresponding statement sequence or
sequence of package declarations.
@node Pragma Unimplemented_Unit
@unnumberedsec Pragma Unimplemented_Unit
@findex Unimplemented_Unit

5
gcc/ada/opt.adb
View File

@ -65,6 +65,7 @@ package body Opt is
Short_Descriptors_Config := Short_Descriptors;
SPARK_Mode_Config := SPARK_Mode;
SPARK_Mode_Pragma_Config := SPARK_Mode_Pragma;
Uneval_Old_Config := Uneval_Old;
Use_VADS_Size_Config := Use_VADS_Size;
Warnings_As_Errors_Count_Config := Warnings_As_Errors_Count;
@ -103,6 +104,7 @@ package body Opt is
Short_Descriptors := Save.Short_Descriptors;
SPARK_Mode := Save.SPARK_Mode;
SPARK_Mode_Pragma := Save.SPARK_Mode_Pragma;
Uneval_Old := Save.Uneval_Old;
Use_VADS_Size := Save.Use_VADS_Size;
Warnings_As_Errors_Count := Save.Warnings_As_Errors_Count;
@ -142,6 +144,7 @@ package body Opt is
Save.Short_Descriptors := Short_Descriptors;
Save.SPARK_Mode := SPARK_Mode;
Save.SPARK_Mode_Pragma := SPARK_Mode_Pragma;
Save.Uneval_Old := Uneval_Old;
Save.Use_VADS_Size := Use_VADS_Size;
Save.Warnings_As_Errors_Count := Warnings_As_Errors_Count;
end Save_Opt_Config_Switches;
@ -171,6 +174,7 @@ package body Opt is
External_Name_Imp_Casing := Lowercase;
Optimize_Alignment := 'O';
Persistent_BSS_Mode := False;
Uneval_Old := 'E';
Use_VADS_Size := False;
Optimize_Alignment_Local := True;
@ -217,6 +221,7 @@ package body Opt is
Persistent_BSS_Mode := Persistent_BSS_Mode_Config;
SPARK_Mode := SPARK_Mode_Config;
SPARK_Mode_Pragma := SPARK_Mode_Pragma_Config;
Uneval_Old := Uneval_Old_Config;
Use_VADS_Size := Use_VADS_Size_Config;
Warnings_As_Errors_Count := Warnings_As_Errors_Count_Config;

10
gcc/ada/opt.ads
View File

@ -1487,6 +1487,11 @@ package Opt is
-- file for the compiler. Indicates that while preprocessing sources,
-- symbols that are not defined have the value FALSE.
Uneval_Old : Character := 'E';
-- GNAT
-- Set to 'E'/'W'/'A' for use of Error/Warn/Allow in a valid pragma
-- Unevaluated_Use_Of_Old.
Unique_Error_Tag : Boolean := Tag_Errors;
-- GNAT
-- Indicates if error messages are to be prefixed by the string error:
@ -1952,6 +1957,10 @@ package Opt is
-- If a SPARK_Mode pragma appeared in the configuration pragmas (setting
-- SPARK_Mode_Config appropriately), then this points to the N_Pragma node.
Uneval_Old_Config : Character;
-- GNAT
-- The setting of Uneval_Old from configuration pragmas
Use_VADS_Size_Config : Boolean;
-- GNAT
-- This is the value of the configuration switch that controls the use of
@ -2122,6 +2131,7 @@ private
Short_Descriptors : Boolean;
SPARK_Mode : SPARK_Mode_Type;
SPARK_Mode_Pragma : Node_Id;
Uneval_Old : Character;
Use_VADS_Size : Boolean;
Warnings_As_Errors_Count : Natural;
end record;

1
gcc/ada/par-prag.adb
View File

@ -1337,6 +1337,7 @@ begin
Pragma_Type_Invariant |
Pragma_Type_Invariant_Class |
Pragma_Unchecked_Union |
Pragma_Unevaluated_Use_Of_Old |
Pragma_Unimplemented_Unit |
Pragma_Universal_Aliasing |
Pragma_Universal_Data |

3
gcc/ada/sem.ads
View File

@ -486,6 +486,9 @@ package Sem is
Save_SPARK_Mode_Pragma : Node_Id;
-- Setting of SPARK_Mode_Pragma on entry to restore on exit
Save_Uneval_Old : Character;
-- Setting of Uneval_Old on entry to restore on exit
Is_Transient : Boolean;
-- Marks transient scopes (see Exp_Ch7 body for details)

39
gcc/ada/sem_attr.adb
View File

@ -409,6 +409,12 @@ package body Sem_Attr is
-- node is rewritten with an integer literal of the given value which
-- is marked as static.
procedure Uneval_Old_Msg;
-- Called when Loop_Entry or Old is used in a potentially unevaluated
-- expression. Generates appropriate message or warning depending on
-- the setting of Opt.Uneval_Old. The caller has put the Name_Id of
-- the attribute in Error_Msg_Name_1 prior to the call.
procedure Unexpected_Argument (En : Node_Id);
-- Signal unexpected attribute argument (En is the argument)
@ -2264,6 +2270,31 @@ package body Sem_Attr is
Set_Is_Static_Expression (N, True);
end Standard_Attribute;
--------------------
-- Uneval_Old_Msg --
--------------------
procedure Uneval_Old_Msg is
begin
case Uneval_Old is
when 'E' =>
Error_Attr_P
("prefix of attribute % that is potentially "
& "unevaluated must denote an entity");
when 'W' =>
Error_Attr_P
("??prefix of attribute % appears in potentially "
& "unevaluated context, exception may be raised");
when 'A' =>
null;
when others =>
raise Program_Error;
end case;
end Uneval_Old_Msg;
-------------------------
-- Unexpected Argument --
-------------------------
@ -4108,9 +4139,7 @@ package body Sem_Attr is
& "outer loop must denote an entity");
elsif Is_Potentially_Unevaluated (P) then
Error_Attr_P
("prefix of attribute % that is potentially "
& "unevaluated must denote an entity");
Uneval_Old_Msg;
end if;
-- Finally, if the Loop_Entry attribute appears within a pragma
@ -4751,9 +4780,7 @@ package body Sem_Attr is
and then Is_Potentially_Unevaluated (N)
and then not Is_Entity_Name (P)
then
Error_Attr_P
("prefix of attribute % that is potentially unevaluated must "
& "denote an entity");
Uneval_Old_Msg;
end if;
-- The attribute appears within a pre/postcondition, but refers to

25
gcc/ada/sem_ch3.adb
View File

@ -1374,10 +1374,12 @@ package body Sem_Ch3 is
-- Note that Has_Task is always false, since the access type itself
-- is not a task type. See Einfo for more description on this point.
-- Exactly the same consideration applies to Has_Controlled_Component.
-- Exactly the same consideration applies to Has_Controlled_Component
-- and to Has_Protected.
Set_Has_Task (T, False);
Set_Has_Task (T, False);
Set_Has_Controlled_Component (T, False);
Set_Has_Protected (T, False);
-- Initialize field Finalization_Master explicitly to Empty, to avoid
-- problems where an incomplete view of this entity has been previously
@ -4177,6 +4179,7 @@ package body Sem_Ch3 is
Set_Etype (T, Parent_Base);
Set_Has_Task (T, Has_Task (Parent_Base));
Set_Has_Protected (T, Has_Task (Parent_Base));
Set_Convention (T, Convention (Parent_Type));
Set_First_Rep_Item (T, First_Rep_Item (Parent_Type));
@ -5167,6 +5170,7 @@ package body Sem_Ch3 is
Set_First_Index (Implicit_Base, First_Index (T));
Set_Component_Type (Implicit_Base, Element_Type);
Set_Has_Task (Implicit_Base, Has_Task (Element_Type));
Set_Has_Protected (Implicit_Base, Has_Protected (Element_Type));
Set_Component_Size (Implicit_Base, Uint_0);
Set_Packed_Array_Impl_Type (Implicit_Base, Empty);
Set_Has_Controlled_Component
@ -5190,6 +5194,7 @@ package body Sem_Ch3 is
Set_First_Index (T, First (Subtype_Marks (Def)));
Set_Has_Delayed_Freeze (T, True);
Set_Has_Task (T, Has_Task (Element_Type));
Set_Has_Protected (T, Has_Protected (Element_Type));
Set_Has_Controlled_Component (T, Has_Controlled_Component
(Element_Type)
or else
@ -8451,9 +8456,10 @@ package body Sem_Ch3 is
Set_Scope (Derived_Type, Current_Scope);
Set_Ekind (Derived_Type, Ekind (Parent_Base));
Set_Etype (Derived_Type, Parent_Base);
Set_Has_Task (Derived_Type, Has_Task (Parent_Base));
Set_Etype (Derived_Type, Parent_Base);
Set_Ekind (Derived_Type, Ekind (Parent_Base));
Set_Has_Task (Derived_Type, Has_Task (Parent_Base));
Set_Has_Protected (Derived_Type, Has_Protected (Parent_Base));
Set_Size_Info (Derived_Type, Parent_Type);
Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
@ -12755,6 +12761,7 @@ package body Sem_Ch3 is
Set_Component_Size (T1, Component_Size (T2));
Set_Has_Controlled_Component (T1, Has_Controlled_Component (T2));
Set_Has_Non_Standard_Rep (T1, Has_Non_Standard_Rep (T2));
Set_Has_Protected (T1, Has_Protected (T2));
Set_Has_Task (T1, Has_Task (T2));
Set_Is_Packed (T1, Is_Packed (T2));
Set_Has_Aliased_Components (T1, Has_Aliased_Components (T2));
@ -18762,7 +18769,9 @@ package body Sem_Ch3 is
Set_Class_Wide_Type
(Base_Type (Full_T), Class_Wide_Type (Priv_T));
Set_Has_Task (Class_Wide_Type (Priv_T), Has_Task (Full_T));
Set_Has_Task (Class_Wide_Type (Priv_T), Has_Task (Full_T));
Set_Has_Protected
(Class_Wide_Type (Priv_T), Has_Protected (Full_T));
end if;
end;
end if;
@ -20309,6 +20318,10 @@ package body Sem_Ch3 is
Set_Has_Task (T);
end if;
if Has_Protected (Etype (Component)) then
Set_Has_Protected (T);
end if;
if Ekind (Component) /= E_Component then
null;

7
gcc/ada/sem_ch4.adb
View File

@ -644,7 +644,7 @@ package body Sem_Ch4 is
-- a similar test should be applied to an allocator with a
-- qualified expression ???
if Is_Protected_Type (Type_Id) then
if Has_Protected (Type_Id) then
Check_Restriction (No_Protected_Type_Allocators, N);
end if;
@ -737,11 +737,8 @@ package body Sem_Ch4 is
-- Check that an allocator of a nested access type doesn't create a
-- protected object when restriction No_Local_Protected_Objects applies.
-- We don't have an equivalent to Has_Task for protected types, so only
-- cases where the designated type itself is a protected type are
-- currently checked. ???
if Is_Protected_Type (Designated_Type (Acc_Type))
if Has_Protected (Designated_Type (Acc_Type))
and then not Is_Library_Level_Entity (Acc_Type)
then
Check_Restriction (No_Local_Protected_Objects, N);

13
gcc/ada/sem_ch7.adb
View File

@ -2369,11 +2369,14 @@ package body Sem_Ch7 is
if Priv_Is_Base_Type then
Set_Is_Controlled (Priv, Is_Controlled (Base_Type (Full)));
Set_Finalize_Storage_Only (Priv, Finalize_Storage_Only
(Base_Type (Full)));
Set_Has_Task (Priv, Has_Task (Base_Type (Full)));
Set_Has_Controlled_Component (Priv, Has_Controlled_Component
(Base_Type (Full)));
Set_Finalize_Storage_Only
(Priv, Finalize_Storage_Only
(Base_Type (Full)));
Set_Has_Task (Priv, Has_Task (Base_Type (Full)));
Set_Has_Protected (Priv, Has_Protected (Base_Type (Full)));
Set_Has_Controlled_Component
(Priv, Has_Controlled_Component
(Base_Type (Full)));
end if;
Set_Freeze_Node (Priv, Freeze_Node (Full));

2
gcc/ada/sem_ch8.adb
View File

@ -7533,6 +7533,7 @@ package body Sem_Ch8 is
Default_Pool := SST.Save_Default_Storage_Pool;
SPARK_Mode := SST.Save_SPARK_Mode;
SPARK_Mode_Pragma := SST.Save_SPARK_Mode_Pragma;
Uneval_Old := SST.Save_Uneval_Old;
if Debug_Flag_W then
Write_Str ("<-- exiting scope: ");
@ -7605,6 +7606,7 @@ package body Sem_Ch8 is
SST.Save_Default_Storage_Pool := Default_Pool;
SST.Save_SPARK_Mode := SPARK_Mode;
SST.Save_SPARK_Mode_Pragma := SPARK_Mode_Pragma;
SST.Save_Uneval_Old := Uneval_Old;
if Scope_Stack.Last > Scope_Stack.First then
SST.Component_Alignment_Default := Scope_Stack.Table

6
gcc/ada/sem_ch9.adb
View File

@ -1912,6 +1912,11 @@ package body Sem_Ch9 is
or else Has_Task (Etype (E))
then
Set_Has_Task (Current_Scope);
elsif Is_Protected_Type (Etype (E))
or else Has_Protected (Etype (E))
then
Set_Has_Protected (Current_Scope);
end if;
Next_Entity (E);
@ -1958,6 +1963,7 @@ package body Sem_Ch9 is
Set_Ekind (T, E_Protected_Type);
Set_Is_First_Subtype (T, True);
Set_Has_Protected (T, True);
Init_Size_Align (T);
Set_Etype (T, T);
Set_Has_Delayed_Freeze (T, True);

25
gcc/ada/sem_prag.adb
View File

@ -21182,6 +21182,30 @@ package body Sem_Prag is
Ada_2005_Pragma;
Process_Suppress_Unsuppress (False);
----------------------------
-- Unevaluated_Use_Of_Old --
----------------------------
-- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
when Pragma_Unevaluated_Use_Of_Old =>
GNAT_Pragma;
Check_Arg_Count (1);
Check_No_Identifiers;
Check_Arg_Is_One_Of (Arg1, Name_Error, Name_Warn, Name_Allow);
-- Suppress/Unsuppress can appear as a configuration pragma, or in
-- a declarative part or a package spec.
if not Is_Configuration_Pragma then
Check_Is_In_Decl_Part_Or_Package_Spec;
end if;
-- Store proper setting of Uneval_Old
Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
Uneval_Old := Fold_Upper (Name_Buffer (1));
-------------------
-- Use_VADS_Size --
-------------------
@ -25442,6 +25466,7 @@ package body Sem_Prag is
Pragma_Unreferenced_Objects => -1,
Pragma_Unreserve_All_Interrupts => -1,
Pragma_Unsuppress => 0,
Pragma_Unevaluated_Use_Of_Old => 0,
Pragma_Use_VADS_Size => -1,
Pragma_Validity_Checks => -1,
Pragma_Volatile => 0,

4
gcc/ada/snames.ads-tmpl
View File

@ -442,6 +442,7 @@ package Snames is
Name_Suppress : constant Name_Id := N + $;
Name_Suppress_Exception_Locations : constant Name_Id := N + $; -- GNAT
Name_Task_Dispatching_Policy : constant Name_Id := N + $;
Name_Unevaluated_Use_Of_Old : constant Name_Id := N + $; -- GNAT
Name_Universal_Data : constant Name_Id := N + $; -- AAMP
Name_Unsuppress : constant Name_Id := N + $; -- Ada 05
Name_Use_VADS_Size : constant Name_Id := N + $; -- GNAT
@ -687,6 +688,7 @@ package Snames is
-- Other special names used in processing pragmas
Name_Allow : constant Name_Id := N + $;
Name_Amount : constant Name_Id := N + $;
Name_As_Is : constant Name_Id := N + $;
Name_Assertion : constant Name_Id := N + $;
@ -811,6 +813,7 @@ package Snames is
Name_Vector : constant Name_Id := N + $;
Name_VMS : constant Name_Id := N + $;
Name_Vtable_Ptr : constant Name_Id := N + $;
Name_Warn : constant Name_Id := N + $;
Name_Working_Storage : constant Name_Id := N + $;
-- Names of recognized attributes. The entries with the comment "Ada 83"
@ -1791,6 +1794,7 @@ package Snames is
Pragma_Suppress,
Pragma_Suppress_Exception_Locations,
Pragma_Task_Dispatching_Policy,
Pragma_Unevaluated_Use_Of_Old,
Pragma_Universal_Data,
Pragma_Unsuppress,
Pragma_Use_VADS_Size,