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

[multiple changes] 

2012-06-26  Vincent Pucci  <pucci@adacore.com>

	* exp_ch3.adb (Build_Init_Statements): Don't check the parents
	in the Rep Item Chain of the task for aspects Interrupt_Priority,
	Priority, CPU and Dispatching_Domain.
	* exp_ch9.adb (Expand_N_Task_Type_Declaration): fields _Priority,
	_CPU and _Domain are present in the corresponding record type
	only if the task entity has a pragma, attribute definition
	clause or aspect specification.
	(Make_Initialize_Protection): Don't check the parents in the Rep Item
	Chain of the task for aspects Interrupt_Priority, Priority, CPU and
	Dispatching_Domain.
	* freeze.adb (Freeze_Entity): Use of Evaluate_Aspects_At_Freeze_Point
	call replaced by Analyze_Aspects_At_Freeze_Point.
	* sem_ch13.adb, sem_ch13.ads (Analyze_Aspects_At_Freeze_Point):
	Renaming of Evaluate_Aspects_At_Freeze_Point.

2012-06-26  Yannick Moy  <moy@adacore.com>

	* sem_attr.adb (Analyze_Attribute): Detect if 'Old is used outside a
	postcondition, and issue an error in such a case.

2012-06-26  Yannick Moy  <moy@adacore.com>

	* gnat_rm.texi: Minor editing.

2012-06-26  Tristan Gingold  <gingold@adacore.com>

	* raise-gcc.c: Minor cleanup: remove unused prototype.
	* seh_init.c: Do not create an image wide unwind info to catch
	SEH when SEH unwind info are emitted by the compiler.

From-SVN: r188995
This commit is contained in:
Arnaud Charlet 2012-06-26 22:11:28 +02:00
parent 59b7e90faf
commit 8a0320ad5e
10 changed files with 433 additions and 407 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
gcc/ada/ChangeLog
View File

@ -1,3 +1,35 @@
2012-06-26 Vincent Pucci <pucci@adacore.com>
* exp_ch3.adb (Build_Init_Statements): Don't check the parents
in the Rep Item Chain of the task for aspects Interrupt_Priority,
Priority, CPU and Dispatching_Domain.
* exp_ch9.adb (Expand_N_Task_Type_Declaration): fields _Priority,
_CPU and _Domain are present in the corresponding record type
only if the task entity has a pragma, attribute definition
clause or aspect specification.
(Make_Initialize_Protection): Don't check the parents in the Rep Item
Chain of the task for aspects Interrupt_Priority, Priority, CPU and
Dispatching_Domain.
* freeze.adb (Freeze_Entity): Use of Evaluate_Aspects_At_Freeze_Point
call replaced by Analyze_Aspects_At_Freeze_Point.
* sem_ch13.adb, sem_ch13.ads (Analyze_Aspects_At_Freeze_Point):
Renaming of Evaluate_Aspects_At_Freeze_Point.
2012-06-26 Yannick Moy <moy@adacore.com>
* sem_attr.adb (Analyze_Attribute): Detect if 'Old is used outside a
postcondition, and issue an error in such a case.
2012-06-26 Yannick Moy <moy@adacore.com>
* gnat_rm.texi: Minor editing.
2012-06-26 Tristan Gingold <gingold@adacore.com>
* raise-gcc.c: Minor cleanup: remove unused prototype.
* seh_init.c: Do not create an image wide unwind info to catch
SEH when SEH unwind info are emitted by the compiler.
2012-06-19 Steven Bosscher <steven@gcc.gnu.org>
* gcc-interface/trans.c: Include target.h.

4
gcc/ada/exp_ch3.adb
View File

@ -2668,7 +2668,9 @@ package body Exp_Ch3 is
Ritem :=
Get_Rep_Item
(Corresponding_Concurrent_Type (Scope (Id)), Nam);
(Corresponding_Concurrent_Type (Scope (Id)),
Nam,
Check_Parents => False);
if Present (Ritem) then

101
gcc/ada/exp_ch9.adb
View File

@ -11270,30 +11270,36 @@ package body Exp_Ch9 is
-- in the pragma, and is used to override the task stack size otherwise
-- associated with the task type.
-- The _Priority field is always present. It will be filled at the freeze
-- point, when the record init proc is built, to capture the expression of
-- a Priority pragma, attribute definition clause or aspect specification
-- (see Build_Record_Init_Proc in Exp_Ch3).
-- The _Priority field is present only if the task entity has a Priority or
-- Interrupt_Priority rep item (pragma, aspect specification or attribute
-- definition clause). It will be filled at the freeze point, when the
-- record init proc is built, to capture the expression of the rep item
-- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled
-- here since aspect evaluations are delayed till the freeze point.
-- The _Task_Info field is present only if a Task_Info pragma appears in
-- the task definition. The expression captures the argument that was
-- present in the pragma, and is used to provide the Task_Image parameter
-- to the call to Create_Task.
-- The _CPU field is always present. It will be filled at the freeze point,
-- when the record init proc is built, to capture the expression of a CPU
-- pragma, attribute definition clause or aspect specification (see
-- Build_Record_Init_Proc in Exp_Ch3).
-- The _CPU field is present only if the task entity has a CPU rep item
-- (pragma, aspect specification or attribute definition clause). It will
-- be filled at the freeze point, when the record init proc is built, to
-- capture the expression of the rep item (see Build_Record_Init_Proc in
-- Exp_Ch3). Note that it cannot be filled here since aspect evaluations
-- are delayed till the freeze point.
-- The _Relative_Deadline field is present only if a Relative_Deadline
-- pragma appears in the task definition. The expression captures the
-- argument that was present in the pragma, and is used to provide the
-- Relative_Deadline parameter to the call to Create_Task.
-- The _Domain field is always present. It will be filled at the freeze
-- point, when the record init proc is built, to capture the expression of
-- a Dispatching_Domain pragma, attribute definition clause or aspect
-- specification (see Build_Record_Init_Proc in Exp_Ch3).
-- The _Domain field is present only if the task entity has a
-- Dispatching_Domain rep item (pragma, aspect specification or attribute
-- definition clause). It will be filled at the freeze point, when the
-- record init proc is built, to capture the expression of the rep item
-- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled
-- here since aspect evaluations are delayed till the freeze point.
-- When a task is declared, an instance of the task value record is
-- created. The elaboration of this declaration creates the correct bounds
@ -11566,17 +11572,20 @@ package body Exp_Ch9 is
Collect_Entry_Families (Loc, Cdecls, Size_Decl, Tasktyp);
-- Add the _Priority component with no expression
-- Add the _Priority component if a Interrupt_Priority or Priority rep
-- item is present.
Append_To (Cdecls,
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uPriority),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication =>
New_Reference_To (Standard_Integer, Loc))));
if Has_Rep_Item (TaskId, Name_Priority, Check_Parents => False) then
Append_To (Cdecls,
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uPriority),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication =>
New_Reference_To (Standard_Integer, Loc))));
end if;
-- Add the _Size component if a Storage_Size pragma is present
@ -11623,18 +11632,20 @@ package body Exp_Ch9 is
(TaskId, Name_Task_Info, Check_Parents => False)))))));
end if;
-- Add the _CPU component with no expression
-- Add the _CPU component if a CPU rep item is present
Append_To (Cdecls,
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uCPU),
if Has_Rep_Item (TaskId, Name_CPU, Check_Parents => False) then
Append_To (Cdecls,
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uCPU),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication =>
New_Reference_To (RTE (RE_CPU_Range), Loc))));
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication =>
New_Reference_To (RTE (RE_CPU_Range), Loc))));
end if;
-- Add the _Relative_Deadline component if a Relative_Deadline pragma is
-- present. If we are using a restricted run time this component will
@ -11663,11 +11674,16 @@ package body Exp_Ch9 is
Get_Relative_Deadline_Pragma (Taskdef))))))));
end if;
-- Add the _Dispatching_Domain component with no expression. If we are
-- using a restricted run time this component will not be added
-- (dispatching domains are not allowed by the Ravenscar profile).
-- Add the _Dispatching_Domain component if a Dispatching_Domain rep
-- item is present. If we are using a restricted run time this component
-- will not be added (dispatching domains are not allowed by the
-- Ravenscar profile).
if not Restricted_Profile then
if not Restricted_Profile
and then
Has_Rep_Item
(TaskId, Name_Dispatching_Domain, Check_Parents => False)
then
Append_To (Cdecls,
Make_Component_Declaration (Loc,
Defining_Identifier =>
@ -13344,10 +13360,11 @@ package body Exp_Ch9 is
-- Interrupt_Priority'Last, an implementation-defined value, see
-- (RM D.3(10)).
if Has_Rep_Item (Ptyp, Name_Priority) then
if Has_Rep_Item (Ptyp, Name_Priority, Check_Parents => False) then
declare
Prio_Clause : constant Node_Id :=
Get_Rep_Item (Ptyp, Name_Priority);
Get_Rep_Item
(Ptyp, Name_Priority, Check_Parents => False);
Prio : Node_Id;
Temp : Entity_Id;
@ -13670,7 +13687,7 @@ package body Exp_Ch9 is
-- Priority parameter. Set to Unspecified_Priority unless there is a
-- Priority rep item, in which case we take the value from the rep item.
if Has_Rep_Item (Ttyp, Name_Priority) then
if Has_Rep_Item (Ttyp, Name_Priority, Check_Parents => False) then
Append_To (Args,
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
@ -13741,7 +13758,7 @@ package body Exp_Ch9 is
-- passed as an Integer because in the case of unspecified CPU the
-- value is not in the range of CPU_Range.
if Has_Rep_Item (Ttyp, Name_CPU) then
if Has_Rep_Item (Ttyp, Name_CPU, Check_Parents => False) then
Append_To (Args,
Convert_To (Standard_Integer,
Make_Selected_Component (Loc,
@ -13790,7 +13807,9 @@ package body Exp_Ch9 is
-- Case where Dispatching_Domain rep item applies: use given value
if Has_Rep_Item (Ttyp, Name_Dispatching_Domain) then
if Has_Rep_Item
(Ttyp, Name_Dispatching_Domain, Check_Parents => False)
then
Append_To (Args,
Make_Selected_Component (Loc,
Prefix =>

6
gcc/ada/freeze.adb
View File

@ -2525,14 +2525,14 @@ package body Freeze is
end if;
-- Deal with delayed aspect specifications. The analysis of the
-- aspect is required to be delayed to the freeze point, so we
-- evaluate the pragma or attribute definition clause in the tree at
-- aspect is required to be delayed to the freeze point, thus we
-- analyze the pragma or attribute definition clause in the tree at
-- this point. We also analyze the aspect specification node at the
-- freeze point when the aspect doesn't correspond to
-- pragma/attribute definition clause.
if Has_Delayed_Aspects (E) then
Evaluate_Aspects_At_Freeze_Point (E);
Analyze_Aspects_At_Freeze_Point (E);
end if;
-- Here to freeze the entity

49
gcc/ada/gnat_rm.texi
View File

@ -265,7 +265,6 @@ Implementation Defined Attributes
* Mechanism_Code::
* Null_Parameter::
* Object_Size::
* Old::
* Passed_By_Reference::
* Pool_Address::
* Range_Length::
@ -6016,7 +6015,6 @@ consideration, you should minimize the use of these attributes.
* Mechanism_Code::
* Null_Parameter::
* Object_Size::
* Old::
* Passed_By_Reference::
* Pool_Address::
* Range_Length::
@ -6627,53 +6625,6 @@ alignment will be 4, because of the
integer field, and so the default size of record objects for this type
will be 64 (8 bytes).
@node Old
@unnumberedsec Old
@cindex Capturing Old values
@cindex Postconditions
@noindent
The attribute Prefix'Old can be used within a
subprogram body or within a precondition or
postcondition pragma. The effect is to
refer to the value of the prefix on entry. So for
example if you have an argument of a record type X called Arg1,
you can refer to Arg1.Field'Old which yields the value of
Arg1.Field on entry. The implementation simply involves generating
an object declaration which captures the value on entry.
The prefix must denote an object of a nonlimited type (since limited types
cannot be copied to capture their values) and it must not reference a local
variable (since local variables do not exist at subprogram entry time). Note
that the variable introduced by a quantified expression is a local variable.
The following example shows the use of 'Old to implement
a test of a postcondition:
@smallexample @c ada
with Old_Pkg;
procedure Old is
begin
Old_Pkg.Incr;
end Old;
package Old_Pkg is
procedure Incr;
end Old_Pkg;
package body Old_Pkg is
Count : Natural := 0;
procedure Incr is
begin
... code manipulating the value of Count
pragma Assert (Count = Count'Old + 1);
end Incr;
end Old_Pkg;
@end smallexample
@noindent
Note that it is allowed to apply 'Old to a constant entity, but this will
result in a warning, since the old and new values will always be the same.
@node Passed_By_Reference
@unnumberedsec Passed_By_Reference
@cindex Parameters, when passed by reference

5
gcc/ada/raise-gcc.c
View File

@ -439,9 +439,9 @@ db_phases (int phases)
|
+--> __gnat_personality_v0 (context, exception)
|
+--> get_region_descriptor_for (context)
+--> get_region_description_for (context)
|
+--> get_action_descriptor_for (context, exception, region)
+--> get_action_description_for (context, exception, region)
| |
| +--> get_call_site_action_for (context, region)
| (one version for each underlying scheme)
@ -1019,7 +1019,6 @@ setup_to_install (_Unwind_Context *uw_context,
automatic backtraces upon exception raise, as provided through the
GNAT.Traceback facilities. */
extern void __gnat_notify_handled_exception (void);
extern void __gnat_notify_unhandled_exception (void);
/* Below is the eh personality routine per se. We currently assume that only
GNU-Ada exceptions are met. */

6
gcc/ada/seh_init.c
View File

@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
* Copyright (C) 2005-2011, Free Software Foundation, Inc. *
* Copyright (C) 2005-2012, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@ -219,6 +219,9 @@ __gnat_SEH_error_handler (struct _EXCEPTION_RECORD* ExceptionRecord,
the loaded DLL (for example it results in unexpected behaviors in the
Win32 subsystem. */
#ifndef __SEH__
/* Don't use this trick when SEH are emitted by gcc, as it will conflict with
them. */
asm
(
" .section .rdata, \"dr\"\n"
@ -238,6 +241,7 @@ asm
"\n"
" .text\n"
);
#endif /* __SEH__ */
void __gnat_install_SEH_handler (void *eh ATTRIBUTE_UNUSED)
{

189
gcc/ada/sem_attr.adb
View File

@ -3905,10 +3905,95 @@ package body Sem_Attr is
-- Old --
---------
when Attribute_Old =>
when Attribute_Old => Old : declare
CS : Entity_Id;
-- The enclosing scope, excluding loops for quantified expressions.
-- During analysis, it is the postcondition subprogram. During
-- pre-analysis, it is the scope of the subprogram declaration.
-- The attribute reference is a primary. If expressions follow, the
-- attribute reference is an indexable object, so rewrite the node
Prag : Node_Id;
-- During pre-analysis, Prag is the enclosing pragma node if any
begin
-- Find enclosing scopes, excluding loops
CS := Current_Scope;
while Ekind (CS) = E_Loop loop
CS := Scope (CS);
end loop;
-- If we are in Spec_Expression mode, this should be the prescan of
-- the postcondition (or contract case, or test case) pragma.
if In_Spec_Expression then
-- Check in postcondition or Ensures clause
Prag := N;
while not Nkind_In (Prag, N_Pragma,
N_Function_Specification,
N_Procedure_Specification,
N_Subprogram_Body)
loop
Prag := Parent (Prag);
end loop;
if Nkind (Prag) /= N_Pragma then
Error_Attr ("% attribute can only appear in postcondition", P);
elsif Get_Pragma_Id (Prag) = Pragma_Contract_Case
or else
Get_Pragma_Id (Prag) = Pragma_Test_Case
then
declare
Arg_Ens : constant Node_Id :=
Get_Ensures_From_CTC_Pragma (Prag);
Arg : Node_Id;
begin
Arg := N;
while Arg /= Prag and Arg /= Arg_Ens loop
Arg := Parent (Arg);
end loop;
if Arg /= Arg_Ens then
if Get_Pragma_Id (Prag) = Pragma_Contract_Case then
Error_Attr
("% attribute misplaced inside contract case", P);
else
Error_Attr
("% attribute misplaced inside test case", P);
end if;
end if;
end;
elsif Get_Pragma_Id (Prag) /= Pragma_Postcondition then
Error_Attr ("% attribute can only appear in postcondition", P);
end if;
-- Body case, where we must be inside a generated _Postcondition
-- procedure, or else the attribute use is definitely misplaced. The
-- postcondition itself may have generated transient scopes, and is
-- not necessarily the current one.
else
while Present (CS) and then CS /= Standard_Standard loop
if Chars (CS) = Name_uPostconditions then
exit;
else
CS := Scope (CS);
end if;
end loop;
if Chars (CS) /= Name_uPostconditions then
Error_Attr ("% attribute can only appear in postcondition", P);
end if;
end if;
-- Either the attribute reference is generated for a Requires
-- clause, in which case no expressions follow, or it is a
-- primary. In that case, if expressions follow, the attribute
-- reference is an indexable object, so rewrite the node
-- accordingly.
if Present (E1) then
@ -3926,17 +4011,13 @@ package body Sem_Attr is
Check_E0;
-- Prefix has not been analyzed yet, and its full analysis will take
-- place during expansion (see below).
-- Prefix has not been analyzed yet, and its full analysis will
-- take place during expansion (see below).
Preanalyze_And_Resolve (P);
P_Type := Etype (P);
Set_Etype (N, P_Type);
if No (Current_Subprogram) then
Error_Attr ("attribute % can only appear within subprogram", N);
end if;
if Is_Limited_Type (P_Type) then
Error_Attr ("attribute % cannot apply to limited objects", P);
end if;
@ -3948,77 +4029,14 @@ package body Sem_Attr is
("?attribute Old applied to constant has no effect", P);
end if;
-- Check that the expression does not refer to local entities
Check_Local : declare
Subp : Entity_Id := Current_Subprogram;
function Process (N : Node_Id) return Traverse_Result;
-- Check that N does not contain references to local variables or
-- other local entities of Subp.
-------------
-- Process --
-------------
function Process (N : Node_Id) return Traverse_Result is
begin
if Is_Entity_Name (N)
and then Present (Entity (N))
and then not Is_Formal (Entity (N))
and then Enclosing_Subprogram (Entity (N)) = Subp
then
Error_Msg_Node_1 := Entity (N);
Error_Attr
("attribute % cannot refer to local variable&", N);
end if;
return OK;
end Process;
procedure Check_No_Local is new Traverse_Proc;
-- Start of processing for Check_Local
begin
Check_No_Local (P);
if In_Parameter_Specification (P) then
-- We have additional restrictions on using 'Old in parameter
-- specifications.
if Present (Enclosing_Subprogram (Current_Subprogram)) then
-- Check that there is no reference to the enclosing
-- subprogram local variables. Otherwise, we might end up
-- being called from the enclosing subprogram and thus using
-- 'Old on a local variable which is not defined at entry
-- time.
Subp := Enclosing_Subprogram (Current_Subprogram);
Check_No_Local (P);
else
-- We must prevent default expression of library-level
-- subprogram from using 'Old, as the subprogram may be
-- used in elaboration code for which there is no enclosing
-- subprogram.
Error_Attr
("attribute % can only appear within subprogram", N);
end if;
end if;
end Check_Local;
-- The attribute appears within a pre/postcondition, but refers to
-- an entity in the enclosing subprogram. If it is a component of a
-- formal its expansion might generate actual subtypes that may be
-- referenced in an inner context, and which must be elaborated
-- within the subprogram itself. As a result we create a declaration
-- for it and insert it at the start of the enclosing subprogram
-- This is properly an expansion activity but it has to be performed
-- now to prevent out-of-order issues.
-- an entity in the enclosing subprogram. If it is a component of
-- a formal its expansion might generate actual subtypes that may
-- be referenced in an inner context, and which must be elaborated
-- within the subprogram itself. As a result we create a
-- declaration for it and insert it at the start of the enclosing
-- subprogram. This is properly an expansion activity but it has
-- to be performed now to prevent out-of-order issues.
if Nkind (P) = N_Selected_Component
and then Has_Discriminants (Etype (Prefix (P)))
@ -4028,6 +4046,7 @@ package body Sem_Attr is
Set_Etype (P, P_Type);
Expand (N);
end if;
end Old;
----------------------
-- Overlaps_Storage --
@ -4261,9 +4280,9 @@ package body Sem_Attr is
end if;
-- If we are in the scope of a function and in Spec_Expression mode,
-- this is likely the prescan of the postcondition pragma, and we
-- just set the proper type. If there is an error it will be caught
-- when the real Analyze call is done.
-- this is likely the prescan of the postcondition (or contract case,
-- or test case) pragma, and we just set the proper type. If there is
-- an error it will be caught when the real Analyze call is done.
if Ekind (CS) = E_Function
and then In_Spec_Expression
@ -4278,7 +4297,7 @@ package body Sem_Attr is
Error_Attr;
end if;
-- Check in postcondition of function
-- Check in postcondition or Ensures clause of function
Prag := N;
while not Nkind_In (Prag, N_Pragma,
@ -4352,8 +4371,8 @@ package body Sem_Attr is
end if;
-- Body case, where we must be inside a generated _Postcondition
-- procedure, and the prefix must be on the scope stack, or else
-- the attribute use is definitely misplaced. The condition itself
-- procedure, and the prefix must be on the scope stack, or else the
-- attribute use is definitely misplaced. The postcondition itself
-- may have generated transient scopes, and is not necessarily the
-- current one.

442
gcc/ada/sem_ch13.adb
View File

@ -682,6 +682,227 @@ package body Sem_Ch13 is
end if;
end Alignment_Check_For_Size_Change;
-------------------------------------
-- Analyze_Aspects_At_Freeze_Point --
-------------------------------------
procedure Analyze_Aspects_At_Freeze_Point (E : Entity_Id) is
ASN : Node_Id;
A_Id : Aspect_Id;
Ritem : Node_Id;
procedure Analyze_Aspect_Default_Value (ASN : Node_Id);
-- This routine analyzes an Aspect_Default_[Component_]Value denoted by
-- the aspect specification node ASN.
procedure Make_Pragma_From_Boolean_Aspect (ASN : Node_Id);
-- Given an aspect specification node ASN whose expression is an
-- optional Boolean, this routines creates the corresponding pragma
-- at the freezing point.
----------------------------------
-- Analyze_Aspect_Default_Value --
----------------------------------
procedure Analyze_Aspect_Default_Value (ASN : Node_Id) is
Ent : constant Entity_Id := Entity (ASN);
Expr : constant Node_Id := Expression (ASN);
Id : constant Node_Id := Identifier (ASN);
begin
Error_Msg_Name_1 := Chars (Id);
if not Is_Type (Ent) then
Error_Msg_N ("aspect% can only apply to a type", Id);
return;
elsif not Is_First_Subtype (Ent) then
Error_Msg_N ("aspect% cannot apply to subtype", Id);
return;
elsif A_Id = Aspect_Default_Value
and then not Is_Scalar_Type (Ent)
then
Error_Msg_N ("aspect% can only be applied to scalar type", Id);
return;
elsif A_Id = Aspect_Default_Component_Value then
if not Is_Array_Type (Ent) then
Error_Msg_N ("aspect% can only be applied to array type", Id);
return;
elsif not Is_Scalar_Type (Component_Type (Ent)) then
Error_Msg_N ("aspect% requires scalar components", Id);
return;
end if;
end if;
Set_Has_Default_Aspect (Base_Type (Ent));
if Is_Scalar_Type (Ent) then
Set_Default_Aspect_Value (Ent, Expr);
else
Set_Default_Aspect_Component_Value (Ent, Expr);
end if;
end Analyze_Aspect_Default_Value;
-------------------------------------
-- Make_Pragma_From_Boolean_Aspect --
-------------------------------------
procedure Make_Pragma_From_Boolean_Aspect (ASN : Node_Id) is
Ident : constant Node_Id := Identifier (ASN);
A_Name : constant Name_Id := Chars (Ident);
A_Id : constant Aspect_Id := Get_Aspect_Id (A_Name);
Ent : constant Entity_Id := Entity (ASN);
Expr : constant Node_Id := Expression (ASN);
Loc : constant Source_Ptr := Sloc (ASN);
Prag : Node_Id;
procedure Check_False_Aspect_For_Derived_Type;
-- This procedure checks for the case of a false aspect for a derived
-- type, which improperly tries to cancel an aspect inherited from
-- the parent.
-----------------------------------------
-- Check_False_Aspect_For_Derived_Type --
-----------------------------------------
procedure Check_False_Aspect_For_Derived_Type is
Par : Node_Id;
begin
-- We are only checking derived types
if not Is_Derived_Type (E) then
return;
end if;
Par := Nearest_Ancestor (E);
case A_Id is
when Aspect_Atomic | Aspect_Shared =>
if not Is_Atomic (Par) then
return;
end if;
when Aspect_Atomic_Components =>
if not Has_Atomic_Components (Par) then
return;
end if;
when Aspect_Discard_Names =>
if not Discard_Names (Par) then
return;
end if;
when Aspect_Pack =>
if not Is_Packed (Par) then
return;
end if;
when Aspect_Unchecked_Union =>
if not Is_Unchecked_Union (Par) then
return;
end if;
when Aspect_Volatile =>
if not Is_Volatile (Par) then
return;
end if;
when Aspect_Volatile_Components =>
if not Has_Volatile_Components (Par) then
return;
end if;
when others =>
return;
end case;
-- Fall through means we are canceling an inherited aspect
Error_Msg_Name_1 := A_Name;
Error_Msg_NE ("derived type& inherits aspect%, cannot cancel",
Expr,
E);
end Check_False_Aspect_For_Derived_Type;
-- Start of processing for Make_Pragma_From_Boolean_Aspect
begin
if Is_False (Static_Boolean (Expr)) then
Check_False_Aspect_For_Derived_Type;
else
Prag :=
Make_Pragma (Loc,
Pragma_Argument_Associations => New_List (
New_Occurrence_Of (Ent, Sloc (Ident))),
Pragma_Identifier =>
Make_Identifier (Sloc (Ident), Chars (Ident)));
Set_From_Aspect_Specification (Prag, True);
Set_Corresponding_Aspect (Prag, ASN);
Set_Aspect_Rep_Item (ASN, Prag);
Set_Is_Delayed_Aspect (Prag);
Set_Parent (Prag, ASN);
end if;
end Make_Pragma_From_Boolean_Aspect;
-- Start of processing for Analyze_Aspects_At_Freeze_Point
begin
-- Must be declared in current scope. This is need for a generic
-- context.
if Scope (E) /= Current_Scope then
return;
end if;
-- Look for aspect specification entries for this entity
ASN := First_Rep_Item (E);
while Present (ASN) loop
if Nkind (ASN) = N_Aspect_Specification
and then Entity (ASN) = E
and then Is_Delayed_Aspect (ASN)
then
A_Id := Get_Aspect_Id (Chars (Identifier (ASN)));
case A_Id is
-- For aspects whose expression is an optional Boolean, make
-- the corresponding pragma at the freezing point.
when Boolean_Aspects |
Library_Unit_Aspects =>
Make_Pragma_From_Boolean_Aspect (ASN);
-- Special handling for aspects that don't correspond to
-- pragmas/attributes.
when Aspect_Default_Value |
Aspect_Default_Component_Value =>
Analyze_Aspect_Default_Value (ASN);
when others => null;
end case;
Ritem := Aspect_Rep_Item (ASN);
if Present (Ritem) then
Analyze (Ritem);
end if;
end if;
Next_Rep_Item (ASN);
end loop;
end Analyze_Aspects_At_Freeze_Point;
-----------------------------------
-- Analyze_Aspect_Specifications --
-----------------------------------
@ -1199,7 +1420,6 @@ package body Sem_Ch13 is
-- declaration. We do not have to worry about delay issues
-- since the pragma processing takes care of this.
Set_Is_Delayed_Aspect (Aspect);
Delay_Required := False;
-- Case 3 : Aspects that don't correspond to pragma/attribute
@ -7602,226 +7822,6 @@ package body Sem_Ch13 is
end if;
end Check_Size;
--------------------------------------
-- Evaluate_Aspects_At_Freeze_Point --
--------------------------------------
procedure Evaluate_Aspects_At_Freeze_Point (E : Entity_Id) is
ASN : Node_Id;
A_Id : Aspect_Id;
Ritem : Node_Id;
procedure Analyze_Aspect_Default_Value (ASN : Node_Id);
-- This routine analyzes an Aspect_Default_[Component_]Value denoted by
-- the aspect specification node ASN.
procedure Make_Pragma_From_Boolean_Aspect (ASN : Node_Id);
-- Given an aspect specification node ASN whose expression is an
-- optional Boolean, this routines creates the corresponding pragma
-- at the freezing point.
----------------------------------
-- Analyze_Aspect_Default_Value --
----------------------------------
procedure Analyze_Aspect_Default_Value (ASN : Node_Id) is
Ent : constant Entity_Id := Entity (ASN);
Expr : constant Node_Id := Expression (ASN);
Id : constant Node_Id := Identifier (ASN);
begin
Error_Msg_Name_1 := Chars (Id);
if not Is_Type (Ent) then
Error_Msg_N ("aspect% can only apply to a type", Id);
return;
elsif not Is_First_Subtype (Ent) then
Error_Msg_N ("aspect% cannot apply to subtype", Id);
return;
elsif A_Id = Aspect_Default_Value
and then not Is_Scalar_Type (Ent)
then
Error_Msg_N ("aspect% can only be applied to scalar type", Id);
return;
elsif A_Id = Aspect_Default_Component_Value then
if not Is_Array_Type (Ent) then
Error_Msg_N ("aspect% can only be applied to array type", Id);
return;
elsif not Is_Scalar_Type (Component_Type (Ent)) then
Error_Msg_N ("aspect% requires scalar components", Id);
return;
end if;
end if;
Set_Has_Default_Aspect (Base_Type (Ent));
if Is_Scalar_Type (Ent) then
Set_Default_Aspect_Value (Ent, Expr);
else
Set_Default_Aspect_Component_Value (Ent, Expr);
end if;
end Analyze_Aspect_Default_Value;
-------------------------------------
-- Make_Pragma_From_Boolean_Aspect --
-------------------------------------
procedure Make_Pragma_From_Boolean_Aspect (ASN : Node_Id) is
Ident : constant Node_Id := Identifier (ASN);
A_Name : constant Name_Id := Chars (Ident);
A_Id : constant Aspect_Id := Get_Aspect_Id (A_Name);
Ent : constant Entity_Id := Entity (ASN);
Expr : constant Node_Id := Expression (ASN);
Loc : constant Source_Ptr := Sloc (ASN);
Prag : Node_Id;
procedure Check_False_Aspect_For_Derived_Type;
-- This procedure checks for the case of a false aspect for a derived
-- type, which improperly tries to cancel an aspect inherited from
-- the parent.
-----------------------------------------
-- Check_False_Aspect_For_Derived_Type --
-----------------------------------------
procedure Check_False_Aspect_For_Derived_Type is
Par : Node_Id;
begin
-- We are only checking derived types
if not Is_Derived_Type (E) then
return;
end if;
Par := Nearest_Ancestor (E);
case A_Id is
when Aspect_Atomic | Aspect_Shared =>
if not Is_Atomic (Par) then
return;
end if;
when Aspect_Atomic_Components =>
if not Has_Atomic_Components (Par) then
return;
end if;
when Aspect_Discard_Names =>
if not Discard_Names (Par) then
return;
end if;
when Aspect_Pack =>
if not Is_Packed (Par) then
return;
end if;
when Aspect_Unchecked_Union =>
if not Is_Unchecked_Union (Par) then
return;
end if;
when Aspect_Volatile =>
if not Is_Volatile (Par) then
return;
end if;
when Aspect_Volatile_Components =>
if not Has_Volatile_Components (Par) then
return;
end if;
when others =>
return;
end case;
-- Fall through means we are canceling an inherited aspect
Error_Msg_Name_1 := A_Name;
Error_Msg_NE ("derived type& inherits aspect%, cannot cancel",
Expr,
E);
end Check_False_Aspect_For_Derived_Type;
-- Start of processing for Make_Pragma_From_Boolean_Aspect
begin
if Is_False (Static_Boolean (Expr)) then
Check_False_Aspect_For_Derived_Type;
else
Prag :=
Make_Pragma (Loc,
Pragma_Argument_Associations => New_List (
New_Occurrence_Of (Ent, Sloc (Ident))),
Pragma_Identifier =>
Make_Identifier (Sloc (Ident), Chars (Ident)));
Set_From_Aspect_Specification (Prag, True);
Set_Corresponding_Aspect (Prag, ASN);
Set_Aspect_Rep_Item (ASN, Prag);
Set_Is_Delayed_Aspect (Prag);
Set_Parent (Prag, ASN);
end if;
end Make_Pragma_From_Boolean_Aspect;
-- Start of processing for Evaluate_Aspects_At_Freeze_Point
begin
-- Must be declared in current scope
if Scope (E) /= Current_Scope then
return;
end if;
-- Look for aspect specification entries for this entity
ASN := First_Rep_Item (E);
while Present (ASN) loop
if Nkind (ASN) = N_Aspect_Specification
and then Entity (ASN) = E
and then Is_Delayed_Aspect (ASN)
then
A_Id := Get_Aspect_Id (Chars (Identifier (ASN)));
case A_Id is
-- For aspects whose expression is an optional Boolean, make
-- the corresponding pragma at the freezing point.
when Boolean_Aspects |
Library_Unit_Aspects =>
Make_Pragma_From_Boolean_Aspect (ASN);
-- Special handling for aspects that don't correspond to
-- pragmas/attributes.
when Aspect_Default_Value |
Aspect_Default_Component_Value =>
Analyze_Aspect_Default_Value (ASN);
when others => null;
end case;
Ritem := Aspect_Rep_Item (ASN);
if Present (Ritem) then
Analyze (Ritem);
end if;
end if;
Next_Rep_Item (ASN);
end loop;
end Evaluate_Aspects_At_Freeze_Point;
-------------------------
-- Get_Alignment_Value --
-------------------------

6
gcc/ada/sem_ch13.ads
View File

@ -299,6 +299,9 @@ package Sem_Ch13 is
-- Quite an awkward procedure, but this is an awkard requirement!
procedure Analyze_Aspects_At_Freeze_Point (E : Entity_Id);
-- Analyze all the delayed aspects for entity E at freezing point
procedure Check_Aspect_At_Freeze_Point (ASN : Node_Id);
-- Performs the processing described above at the freeze point, ASN is the
-- N_Aspect_Specification node for the aspect.
@ -307,7 +310,4 @@ package Sem_Ch13 is
-- Performs the processing described above at the freeze all point, and
-- issues appropriate error messages if the visibility has indeed changed.
-- Again, ASN is the N_Aspect_Specification node for the aspect.
procedure Evaluate_Aspects_At_Freeze_Point (E : Entity_Id);
-- Evaluates all the delayed aspects for entity E at freezing point
end Sem_Ch13;