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-12  Robert Dewar  <dewar@adacore.com>

	* switch-c.adb, a-exexpr-gcc.adb: Minor reformatting.

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

	* checks.adb (Tag_Checks_Suppressed): Remove Kill_Tag_Checks check.
	* einfo.adb (Universal_Aliasing): Apply to the implementation
	base type instead of the base type.
	(Get_Rep_Item_For_Entity):
	Return a pragma if the pragma node is not present in the Rep
	Item chain of the parent.
	(Kill_Tag_Checks): Removed (unused flag).
	(Set_Kill_Tag_Checks): Removed.
	(Get_First_Rep_Item): New routine.
	(Get_Rep_Pragma_For_Entity): New routine.
	(Has_Rep_Item): New routine.
	(Has_Rep_Pragma_For_Entity): New routine.
	(Present_In_Rep_Item): New routine.
	* einfo.ads (Kill_Tag_Checks): Removed.
	(Set_Kill_Tag_Checks): Removed.
	(Get_First_Rep_Item): New routine.
	(Get_Rep_Pragma_For_Entity): New routine.
	(Has_Rep_Item): New routine.
	(Has_Rep_Pragma_For_Entity): New routine.
	(Present_In_Rep_Item): New routine.
	* exp_attr.adb, sem_attr.adb: Attribute_CPU,
	Attribute_Dispatching_Domain and Attribute_Interrupt_Priority
	case added.
	* exp_ch13.adb (Expand_N_Attribute_Definition_Clause): For
	attribute Storage_Size, insert the new assignement statement
	after the Size variable declaration.
	* exp_ch3.adb (Build_Init_Statements): Fill the CPU,
	Dispatching_Domain, Priority and Size components with the Rep
	Item expression (if any).
	* exp_ch9.adb (Expand_N_Task_Type_Declaration): _CPU,
	_Priority, _Domain fields are always present in the
	corresponding record type.
	(Find_Task_Or_Protected_Pragma): Removed.
	(Get_Relative_Deadline_Pragma): New routine.
	(Make_Initialize_Protection): Find_Task_Or_Protected_Pragma removed.
	(Make_Task_Create_Call): Check CPU, Size or
	Dispatching_Domain Rep Item is present using new routine Has_Rep_Item.
	* freeze.adb (Freeze_All): Push_Scope_And_Install_Discriminants
	and Uninstall_Discriminants_And_Pop_Scope calls added.
	(Freeze_Entity): Evaluate_Aspects_At_Freeze_Point call added.
	* sem_aux.adb (Nearest_Ancestor): Retrieve the nearest ancestor
	for private derived types.
	* sem_ch13.adb (Analyze_Aspect_Specifications): Clean-up
	and reordering. Delay analysis for all aspects (except some
	peculiar cases).
	(Analyze_Attribute_Definition_Clause):
	Attribute_CPU, Attribute_Dispatching_Domain,
	Interrupt_Priority and Attribute_Priority cases added.
	(Analyze_Freeze_Entity): Push_Scope_And_Install_Discriminants
	and Uninstall_Discriminants_And_Pop_Scope calls added.
	(Check_Aspect_At_Freeze_Point): Reordering and clean-up.
	(Duplicate_Clause): Issue an explicit error msg when the current
	clause duplicates an aspect specification, an attribute definition
	clause or a pragma.
	(Evaluate_Aspects_At_Freeze_Point): New routine.
	* sem_ch13.ads (Evaluate_Aspects_At_Freeze_Point): New routine.
	* sem_ch9.adb, sem_ch9.ads (Install_Discriminants): New routine.
	(Push_Scope_And_Install_Discriminants): New routine.
	(Uninstall_Discriminants): New routine.
	(Uninstall_Discriminants_And_Pop_Scope): New routine.
	* sem_prag.adb (Check_Duplicate_Pragma): Issue an explicit error
	msg when the current pragma duplicates an aspect specification,
	an attribute definition clause or a pragma.
	(Analyze_Pragma): Remove use of flags Has_Pragma_CPU,
	Has_Pragma_Priority and Has_Pragma_Dispatching_Domain.
	* sem_util.adb (Compile_Time_Constraint_Error): Don't complain
	about the type if the corresponding concurrent type doesn't come
	from source.
	* sinfo.adb, sinfo.ads (Has_Pragma_CPU): Removed.
	(Has_Pragma_Dispatching_Domain): Removed.
	(Has_Pragma_Priority): Removed.
	(Has_Task_Info_Pragma): Removed.
	(Has_Task_Name_Pragma): Removed.
	(Set_Has_Pragma_CPU): Removed.
	(Set_Has_Pragma_Dispatching_Domain): Removed.
	(Set_Has_Pragma_Priority): Removed.
	(Set_Has_Task_Info_Pragma): Removed.
	(Set_Has_Task_Name_Pragma): Removed.
	* snames.adb-tmpl (Get_Pragma_Id): Pragma_CPU,
	Pragma_Dispatching_Domain and Pragma_Interrupt_Priority added.
	(Is_Pragma_Name): Name_CPU, Name_Dispatching_Domain and
	Name_Interrupt_Priority added.
	* snames.ads-tmpl: Name_Dispatching_Domain, Name_CPU
	and Name_Interrupt_Priority moved to the list of
	Attribute_Name. Attribute_CPU, Attribute_Dispatching_Domain and
	Attribute_Interrupt_Priority added.  Pragma_Dispatching_Domain,
	Pragma_CPU and Pragma_Interrupt_Priority moved to the end of
	the Pragma_Name list.

From-SVN: r188455
This commit is contained in:
Arnaud Charlet 2012-06-12 15:01:22 +02:00
parent fc7d1319f5
commit b98e296954
23 changed files with 1731 additions and 1283 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

95
gcc/ada/ChangeLog
View File

@ -1,3 +1,98 @@
2012-06-12 Robert Dewar <dewar@adacore.com>
* switch-c.adb, a-exexpr-gcc.adb: Minor reformatting.
2012-06-12 Vincent Pucci <pucci@adacore.com>
* checks.adb (Tag_Checks_Suppressed): Remove Kill_Tag_Checks check.
* einfo.adb (Universal_Aliasing): Apply to the implementation
base type instead of the base type.
(Get_Rep_Item_For_Entity):
Return a pragma if the pragma node is not present in the Rep
Item chain of the parent.
(Kill_Tag_Checks): Removed (unused flag).
(Set_Kill_Tag_Checks): Removed.
(Get_First_Rep_Item): New routine.
(Get_Rep_Pragma_For_Entity): New routine.
(Has_Rep_Item): New routine.
(Has_Rep_Pragma_For_Entity): New routine.
(Present_In_Rep_Item): New routine.
* einfo.ads (Kill_Tag_Checks): Removed.
(Set_Kill_Tag_Checks): Removed.
(Get_First_Rep_Item): New routine.
(Get_Rep_Pragma_For_Entity): New routine.
(Has_Rep_Item): New routine.
(Has_Rep_Pragma_For_Entity): New routine.
(Present_In_Rep_Item): New routine.
* exp_attr.adb, sem_attr.adb: Attribute_CPU,
Attribute_Dispatching_Domain and Attribute_Interrupt_Priority
case added.
* exp_ch13.adb (Expand_N_Attribute_Definition_Clause): For
attribute Storage_Size, insert the new assignement statement
after the Size variable declaration.
* exp_ch3.adb (Build_Init_Statements): Fill the CPU,
Dispatching_Domain, Priority and Size components with the Rep
Item expression (if any).
* exp_ch9.adb (Expand_N_Task_Type_Declaration): _CPU,
_Priority, _Domain fields are always present in the
corresponding record type.
(Find_Task_Or_Protected_Pragma): Removed.
(Get_Relative_Deadline_Pragma): New routine.
(Make_Initialize_Protection): Find_Task_Or_Protected_Pragma removed.
(Make_Task_Create_Call): Check CPU, Size or
Dispatching_Domain Rep Item is present using new routine Has_Rep_Item.
* freeze.adb (Freeze_All): Push_Scope_And_Install_Discriminants
and Uninstall_Discriminants_And_Pop_Scope calls added.
(Freeze_Entity): Evaluate_Aspects_At_Freeze_Point call added.
* sem_aux.adb (Nearest_Ancestor): Retrieve the nearest ancestor
for private derived types.
* sem_ch13.adb (Analyze_Aspect_Specifications): Clean-up
and reordering. Delay analysis for all aspects (except some
peculiar cases).
(Analyze_Attribute_Definition_Clause):
Attribute_CPU, Attribute_Dispatching_Domain,
Interrupt_Priority and Attribute_Priority cases added.
(Analyze_Freeze_Entity): Push_Scope_And_Install_Discriminants
and Uninstall_Discriminants_And_Pop_Scope calls added.
(Check_Aspect_At_Freeze_Point): Reordering and clean-up.
(Duplicate_Clause): Issue an explicit error msg when the current
clause duplicates an aspect specification, an attribute definition
clause or a pragma.
(Evaluate_Aspects_At_Freeze_Point): New routine.
* sem_ch13.ads (Evaluate_Aspects_At_Freeze_Point): New routine.
* sem_ch9.adb, sem_ch9.ads (Install_Discriminants): New routine.
(Push_Scope_And_Install_Discriminants): New routine.
(Uninstall_Discriminants): New routine.
(Uninstall_Discriminants_And_Pop_Scope): New routine.
* sem_prag.adb (Check_Duplicate_Pragma): Issue an explicit error
msg when the current pragma duplicates an aspect specification,
an attribute definition clause or a pragma.
(Analyze_Pragma): Remove use of flags Has_Pragma_CPU,
Has_Pragma_Priority and Has_Pragma_Dispatching_Domain.
* sem_util.adb (Compile_Time_Constraint_Error): Don't complain
about the type if the corresponding concurrent type doesn't come
from source.
* sinfo.adb, sinfo.ads (Has_Pragma_CPU): Removed.
(Has_Pragma_Dispatching_Domain): Removed.
(Has_Pragma_Priority): Removed.
(Has_Task_Info_Pragma): Removed.
(Has_Task_Name_Pragma): Removed.
(Set_Has_Pragma_CPU): Removed.
(Set_Has_Pragma_Dispatching_Domain): Removed.
(Set_Has_Pragma_Priority): Removed.
(Set_Has_Task_Info_Pragma): Removed.
(Set_Has_Task_Name_Pragma): Removed.
* snames.adb-tmpl (Get_Pragma_Id): Pragma_CPU,
Pragma_Dispatching_Domain and Pragma_Interrupt_Priority added.
(Is_Pragma_Name): Name_CPU, Name_Dispatching_Domain and
Name_Interrupt_Priority added.
* snames.ads-tmpl: Name_Dispatching_Domain, Name_CPU
and Name_Interrupt_Priority moved to the list of
Attribute_Name. Attribute_CPU, Attribute_Dispatching_Domain and
Attribute_Interrupt_Priority added. Pragma_Dispatching_Domain,
Pragma_CPU and Pragma_Interrupt_Priority moved to the end of
the Pragma_Name list.
2012-06-12 Arnaud Charlet <charlet@adacore.com>
* xref_lib.adb (Get_Full_Type): Add support for 'G'.

7
gcc/ada/a-exexpr-gcc.adb
View File

@ -109,9 +109,10 @@ package body Exception_Propagation is
Private1 : Unwind_Word;
Private2 : Unwind_Word;
-- Usual exception structure has only 2 private fields, but the SEH
-- one has 6. To avoid makeing this file more complex, we use 6 fields
-- on all platforms, wasting a few bytes on some.
-- Usual exception structure has only two private fields, but the SEH
-- one has six. To avoid makeing this file more complex, we use six
-- fields on all platforms, wasting a few bytes on some.
Private3 : Unwind_Word;
Private4 : Unwind_Word;
Private5 : Unwind_Word;

8
gcc/ada/checks.adb
View File

@ -7378,13 +7378,11 @@ package body Checks is
function Tag_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
if Present (E) then
if Kill_Tag_Checks (E) then
return True;
elsif Checks_May_Be_Suppressed (E) then
if Present (E)
and then Checks_May_Be_Suppressed (E)
then
return Is_Check_Suppressed (E, Tag_Check);
end if;
end if;
return Scope_Suppress (Tag_Check);
end Tag_Checks_Suppressed;

169
gcc/ada/einfo.adb
View File

@ -35,6 +35,7 @@ pragma Style_Checks (All_Checks);
with Atree; use Atree;
with Nlists; use Nlists;
with Output; use Output;
with Sem_Aux; use Sem_Aux;
with Sinfo; use Sinfo;
with Stand; use Stand;
@ -283,7 +284,6 @@ package body Einfo is
-- Checks_May_Be_Suppressed Flag31
-- Kill_Elaboration_Checks Flag32
-- Kill_Range_Checks Flag33
-- Kill_Tag_Checks Flag34
-- Is_Class_Wide_Equivalent_Type Flag35
-- Referenced_As_LHS Flag36
-- Is_Known_Non_Null Flag37
@ -526,6 +526,7 @@ package body Einfo is
-- Has_Anonymous_Master Flag253
-- Is_Implementation_Defined Flag254
-- (unused) Flag34
-- (unused) Flag201
-----------------------
@ -2210,11 +2211,6 @@ package body Einfo is
return Flag33 (Id);
end Kill_Range_Checks;
function Kill_Tag_Checks (Id : E) return B is
begin
return Flag34 (Id);
end Kill_Tag_Checks;
function Known_To_Have_Preelab_Init (Id : E) return B is
begin
pragma Assert (Is_Type (Id));
@ -2781,7 +2777,7 @@ package body Einfo is
function Universal_Aliasing (Id : E) return B is
begin
pragma Assert (Is_Type (Id));
return Flag216 (Base_Type (Id));
return Flag216 (Implementation_Base_Type (Id));
end Universal_Aliasing;
function Unset_Reference (Id : E) return N is
@ -4760,11 +4756,6 @@ package body Einfo is
Set_Flag33 (Id, V);
end Set_Kill_Range_Checks;
procedure Set_Kill_Tag_Checks (Id : E; V : B := True) is
begin
Set_Flag34 (Id, V);
end Set_Kill_Tag_Checks;
procedure Set_Known_To_Have_Preelab_Init (Id : E; V : B := True) is
begin
pragma Assert (Is_Type (Id));
@ -5988,6 +5979,44 @@ package body Einfo is
return Empty;
end Get_Attribute_Definition_Clause;
------------------
-- Get_Rep_Item --
------------------
function Get_Rep_Item
(E : Entity_Id;
Nam : Name_Id) return Node_Id
is
N : Node_Id;
N_Nam : Name_Id := No_Name;
begin
N := First_Rep_Item (E);
while Present (N) loop
if Nkind (N) = N_Pragma then
N_Nam := Pragma_Name (N);
elsif Nkind (N) = N_Attribute_Definition_Clause then
N_Nam := Chars (N);
elsif Nkind (N) = N_Aspect_Specification then
N_Nam := Chars (Identifier (N));
end if;
if N_Nam = Nam
or else (Nam = Name_Priority
and then N_Nam = Name_Interrupt_Priority)
then
return N;
end if;
Next_Rep_Item (N);
end loop;
return Empty;
end Get_Rep_Item;
-------------------
-- Get_Full_View --
-------------------
@ -6036,28 +6065,47 @@ package body Einfo is
(E : Entity_Id;
Nam : Name_Id) return Node_Id
is
Par : constant Entity_Id := Nearest_Ancestor (E);
-- In case of a derived type or subtype, this node represents the parent
-- type of type E.
N : Node_Id;
Arg : Node_Id;
begin
N := First_Rep_Item (E);
while Present (N) loop
if Nkind (N) = N_Pragma and then Pragma_Name (N) = Nam then
Arg := Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
if Nkind (N) = N_Pragma
and then
(Pragma_Name (N) = Nam
or else (Nam = Name_Priority
and then Pragma_Name (N) = Name_Interrupt_Priority))
then
-- Return N if the pragma doesn't appear in the Rep_Item chain of
-- the parent.
if Is_Entity_Name (Arg) and then Entity (Arg) = E then
if No (Par) then
return N;
elsif not Present_In_Rep_Item (Par, N) then
return N;
end if;
elsif Nkind (N) = N_Attribute_Definition_Clause
and then Chars (N) = Nam
and then Entity (N) = E
and then
(Chars (N) = Nam
or else (Nam = Name_Priority
and then Chars (N) = Name_Interrupt_Priority))
then
return N;
elsif Nkind (N) = N_Aspect_Specification
and then Chars (Identifier (N)) = Nam
and then Entity (N) = E
and then
(Chars (Identifier (N)) = Nam
or else (Nam = Name_Priority
and then Chars (Identifier (N)) =
Name_Interrupt_Priority))
then
return N;
end if;
@ -6078,7 +6126,12 @@ package body Einfo is
begin
N := First_Rep_Item (E);
while Present (N) loop
if Nkind (N) = N_Pragma and then Pragma_Name (N) = Nam then
if Nkind (N) = N_Pragma
and then
(Pragma_Name (N) = Nam
or else (Nam = Name_Interrupt_Priority
and then Pragma_Name (N) = Name_Priority))
then
return N;
end if;
@ -6088,6 +6141,30 @@ package body Einfo is
return Empty;
end Get_Rep_Pragma;
-------------------------------
-- Get_Rep_Pragma_For_Entity --
-------------------------------
function Get_Rep_Pragma_For_Entity
(E : Entity_Id; Nam : Name_Id) return Node_Id
is
Par : constant Entity_Id := Nearest_Ancestor (E);
-- In case of a derived type or subtype, this node represents the parent
-- type of type E.
Prag : constant Node_Id := Get_Rep_Pragma (E, Nam);
begin
if No (Par) then
return Prag;
elsif not Present_In_Rep_Item (Par, Prag) then
return Prag;
end if;
return Empty;
end Get_Rep_Pragma_For_Entity;
------------------------
-- Has_Attach_Handler --
------------------------
@ -6112,18 +6189,6 @@ package body Einfo is
return False;
end Has_Attach_Handler;
-------------------------------------
-- Has_Attribute_Definition_Clause --
-------------------------------------
function Has_Attribute_Definition_Clause
(E : Entity_Id;
Id : Attribute_Id) return Boolean
is
begin
return Present (Get_Attribute_Definition_Clause (E, Id));
end Has_Attribute_Definition_Clause;
-----------------
-- Has_Entries --
-----------------
@ -6185,6 +6250,15 @@ package body Einfo is
return False;
end Has_Interrupt_Handler;
------------------
-- Has_Rep_Item --
------------------
function Has_Rep_Item (E : Entity_Id; Nam : Name_Id) return Boolean is
begin
return Present (Get_Rep_Item (E, Nam));
end Has_Rep_Item;
--------------------
-- Has_Rep_Pragma --
--------------------
@ -6194,6 +6268,17 @@ package body Einfo is
return Present (Get_Rep_Pragma (E, Nam));
end Has_Rep_Pragma;
-------------------------------
-- Has_Rep_Pragma_For_Entity --
-------------------------------
function Has_Rep_Pragma_For_Entity
(E : Entity_Id; Nam : Name_Id) return Boolean
is
begin
return Present (Get_Rep_Pragma_For_Entity (E, Nam));
end Has_Rep_Pragma_For_Entity;
--------------------
-- Has_Unmodified --
--------------------
@ -6972,6 +7057,27 @@ package body Einfo is
return Ekind (Id);
end Parameter_Mode;
-------------------------
-- Present_In_Rep_Item --
-------------------------
function Present_In_Rep_Item (E : Entity_Id; N : Node_Id) return Boolean is
Ritem : Node_Id;
begin
Ritem := First_Rep_Item (E);
while Present (Ritem) loop
if Ritem = N then
return True;
end if;
Next_Rep_Item (Ritem);
end loop;
return False;
end Present_In_Rep_Item;
--------------------------
-- Primitive_Operations --
--------------------------
@ -7654,7 +7760,6 @@ package body Einfo is
W ("Itype_Printed", Flag202 (Id));
W ("Kill_Elaboration_Checks", Flag32 (Id));
W ("Kill_Range_Checks", Flag33 (Id));
W ("Kill_Tag_Checks", Flag34 (Id));
W ("Known_To_Have_Preelab_Init", Flag207 (Id));
W ("Low_Bound_Tested", Flag205 (Id));
W ("Machine_Radix_10", Flag84 (Id));

66
gcc/ada/einfo.ads
View File

@ -729,11 +729,11 @@ package Einfo is
-- declared the entity. Normally this is just the Parent of the entity.
-- One exception arises with child units, where the parent of the entity
-- is a selected component/defining program unit name. Another exception
-- is that if the entity is an incomplete type that has been completed,
-- then we obtain the declaration node denoted by the full type, i.e. the
-- full type declaration node. Also note that for subprograms, this
-- returns the {function,procedure}_specification, not the subprogram_
-- declaration.
-- is that if the entity is an incomplete type that has been completed or
-- a private type, then we obtain the declaration node denoted by the
-- full type, i.e. the full type declaration node. Also note that for
-- subprograms, this returns the {function,procedure}_specification, not
-- the subprogram_declaration.
-- Default_Aspect_Component_Value (Node19)
-- Present in array types. Holds the static value specified in a
@ -2907,13 +2907,6 @@ package Einfo is
-- This is currently only used in one odd situation in Sem_Ch3 for
-- record types, and it would be good to get rid of it???
-- Kill_Tag_Checks (Flag34)
-- Present in all entities. Set by the expander to kill elaboration
-- checks which are known not to be needed. Equivalent in effect to
-- the use of pragma Suppress (Tag_Checks) for that entity except
-- that the result is permanent and cannot be undone by a subsequent
-- pragma Unsuppress.
-- Known_To_Have_Preelab_Init (Flag207)
-- Present in all type and subtype entities. If set, then the type is
-- known to have preelaborable initialization. In the case of a partial
@ -4852,7 +4845,6 @@ package Einfo is
-- Is_VMS_Exception (Flag133)
-- Kill_Elaboration_Checks (Flag32)
-- Kill_Range_Checks (Flag33)
-- Kill_Tag_Checks (Flag34)
-- Low_Bound_Tested (Flag205)
-- Materialize_Entity (Flag168)
-- Needs_Debug_Info (Flag147)
@ -6310,7 +6302,6 @@ package Einfo is
function Itype_Printed (Id : E) return B;
function Kill_Elaboration_Checks (Id : E) return B;
function Kill_Range_Checks (Id : E) return B;
function Kill_Tag_Checks (Id : E) return B;
function Known_To_Have_Preelab_Init (Id : E) return B;
function Last_Assignment (Id : E) return N;
function Last_Entity (Id : E) return E;
@ -6907,7 +6898,6 @@ package Einfo is
procedure Set_Itype_Printed (Id : E; V : B := True);
procedure Set_Kill_Elaboration_Checks (Id : E; V : B := True);
procedure Set_Kill_Range_Checks (Id : E; V : B := True);
procedure Set_Kill_Tag_Checks (Id : E; V : B := True);
procedure Set_Known_To_Have_Preelab_Init (Id : E; V : B := True);
procedure Set_Last_Assignment (Id : E; V : N);
procedure Set_Last_Entity (Id : E; V : E);
@ -7200,15 +7190,25 @@ package Einfo is
-- value returned is the N_Attribute_Definition_Clause node, otherwise
-- Empty is returned.
function Get_Rep_Item
(E : Entity_Id;
Nam : Name_Id) return Node_Id;
-- Searches the Rep_Item chain for a given entity E, for the first
-- occurrence of a rep item (pragma, attribute definition clause, or aspect
-- specification) whose name matches the given name. If one is found, it is
-- returned, otherwise Empty is returned. A special case is that when Nam
-- is Name_Priority, the call will also find Interrupt_Priority.
function Get_Rep_Item_For_Entity
(E : Entity_Id;
Nam : Name_Id) return Node_Id;
-- Searches the Rep_Item chain for a given entity E, for an instance of a
-- rep item (pragma, attribute definition clause, or aspect specification)
-- whose name matches the given name. If one is found, it is returned,
-- otherwise Empty is returned. Unlike the other Get routines for the
-- Rep_Item chain, this only returns items whose entity matches E (it
-- does not return items from the parent chain).
-- otherwise Empty is returned. This routine only returns items whose
-- entity matches E (it does not return items from the parent chain). A
-- special case is that when Nam is Name_Priority, the call will also find
-- Interrupt_Priority.
function Get_Record_Representation_Clause (E : Entity_Id) return Node_Id;
-- Searches the Rep_Item chain for a given entity E, for a record
@ -7218,19 +7218,33 @@ package Einfo is
function Get_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Node_Id;
-- Searches the Rep_Item chain for the given entity E, for an instance
-- a representation pragma with the given name Nam. If found then the
-- value returned is the N_Pragma node, otherwise Empty is returned.
-- value returned is the N_Pragma node, otherwise Empty is returned. A
-- special case is that when Nam is Name_Priority, the call will also find
-- Interrupt_Priority.
function Get_Rep_Pragma_For_Entity
(E : Entity_Id; Nam : Name_Id) return Node_Id;
-- Same as Get_Rep_Pragma except that this routine returns a pragma that
-- doesn't appear in the Rep Item chain of the parent of E (if any).
function Has_Rep_Item (E : Entity_Id; Nam : Name_Id) return Boolean;
-- Searches the Rep_Item chain for the given entity E, for an instance
-- of rep item with the given name Nam. If found then True is returned,
-- otherwise False indicates that no matching entry was found.
function Has_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Boolean;
-- Searches the Rep_Item chain for the given entity E, for an instance
-- of representation pragma with the given name Nam. If found then True
-- is returned, otherwise False indicates that no matching entry was found.
function Has_Attribute_Definition_Clause
(E : Entity_Id;
Id : Attribute_Id) return Boolean;
-- Searches the Rep_Item chain for a given entity E, for an instance of an
-- attribute definition clause with the given attribute Id. If found, True
-- is returned, otherwise False indicates that no matching entry was found.
function Has_Rep_Pragma_For_Entity
(E : Entity_Id; Nam : Name_Id) return Boolean;
-- Same as Has_Rep_Pragma except that this routine doesn't return True if
-- the representation pragma is also present in the Rep Item chain of the
-- parent of E (if any).
function Present_In_Rep_Item (E : Entity_Id; N : Node_Id) return Boolean;
-- Return True if N is present in the Rep_Item chain for a given entity E
procedure Record_Rep_Item (E : Entity_Id; N : Node_Id);
-- N is the node for a representation pragma, representation clause, an
@ -7650,7 +7664,6 @@ package Einfo is
pragma Inline (Itype_Printed);
pragma Inline (Kill_Elaboration_Checks);
pragma Inline (Kill_Range_Checks);
pragma Inline (Kill_Tag_Checks);
pragma Inline (Known_To_Have_Preelab_Init);
pragma Inline (Last_Assignment);
pragma Inline (Last_Entity);
@ -8056,7 +8069,6 @@ package Einfo is
pragma Inline (Set_Itype_Printed);
pragma Inline (Set_Kill_Elaboration_Checks);
pragma Inline (Set_Kill_Range_Checks);
pragma Inline (Set_Kill_Tag_Checks);
pragma Inline (Set_Known_To_Have_Preelab_Init);
pragma Inline (Set_Last_Assignment);
pragma Inline (Set_Last_Entity);

16
gcc/ada/exp_attr.adb
View File

@ -831,11 +831,17 @@ package body Exp_Attr is
-- Attributes related to Ada 2012 iterators (placeholder ???)
when Attribute_Constant_Indexing => null;
when Attribute_Default_Iterator => null;
when Attribute_Implicit_Dereference => null;
when Attribute_Iterator_Element => null;
when Attribute_Variable_Indexing => null;
when Attribute_Constant_Indexing |
Attribute_Default_Iterator |
Attribute_Implicit_Dereference |
Attribute_Iterator_Element |
Attribute_Variable_Indexing => null;
-- Attributes related to Ada 2012 aspects
when Attribute_CPU |
Attribute_Dispatching_Domain |
Attribute_Interrupt_Priority => null;
------------
-- Access --

24
gcc/ada/exp_ch13.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1992-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- --
@ -165,14 +165,30 @@ package body Exp_Ch13 is
-- If the type is a task type, then assign the value of the
-- storage size to the Size variable associated with the task.
-- Insert the assignment right after the declaration of the Size
-- variable.
-- Generate:
-- task_typeZ := expression
if Ekind (Ent) = E_Task_Type then
Insert_Action (N,
declare
Assign : Node_Id;
begin
Assign :=
Make_Assignment_Statement (Loc,
Name => New_Reference_To (Storage_Size_Variable (Ent), Loc),
Name =>
New_Reference_To (Storage_Size_Variable (Ent), Loc),
Expression =>
Convert_To (RTE (RE_Size_Type), Expression (N))));
Convert_To (RTE (RE_Size_Type), Expression (N)));
Insert_After
(Parent (Storage_Size_Variable (Entity (N))), Assign);
Analyze (Assign);
end;
-- For Storage_Size for an access type, create a variable to hold
-- the value of the specified size with name typeV and expand an

93
gcc/ada/exp_ch3.adb
View File

@ -2636,6 +2636,99 @@ package body Exp_Ch3 is
Actions := Build_Assignment (Id, Expression (Decl));
end if;
-- CPU, Dispatching_Domain, Priority and Size components are
-- filled with the corresponding rep item expression of the
-- concurrent type (if any).
elsif Ekind (Scope (Id)) = E_Record_Type
and then Present (Corresponding_Concurrent_Type (Scope (Id)))
and then (Chars (Id) = Name_uCPU
or else Chars (Id) = Name_uDispatching_Domain
or else Chars (Id) = Name_uPriority)
then
declare
Exp : Node_Id;
Nam : Name_Id;
Ritem : Node_Id;
begin
if Chars (Id) = Name_uCPU then
Nam := Name_CPU;
elsif Chars (Id) = Name_uDispatching_Domain then
Nam := Name_Dispatching_Domain;
elsif Chars (Id) = Name_uPriority then
Nam := Name_Priority;
end if;
-- Get the Rep Item (aspect specification, attribute
-- definition clause or pragma) of the corresponding
-- concurrent type.
Ritem :=
Get_Rep_Item
(Corresponding_Concurrent_Type (Scope (Id)), Nam);
if Present (Ritem) then
-- Pragma case
if Nkind (Ritem) = N_Pragma then
Exp := First (Pragma_Argument_Associations (Ritem));
if Nkind (Exp) = N_Pragma_Argument_Association then
Exp := Expression (Exp);
end if;
-- Conversion for Priority expression
if Nam = Name_Priority then
if Pragma_Name (Ritem) = Name_Priority
and then not GNAT_Mode
then
Exp := Convert_To (RTE (RE_Priority), Exp);
else
Exp :=
Convert_To (RTE (RE_Any_Priority), Exp);
end if;
end if;
-- Aspect/Attribute definition clause case
else
Exp := Expression (Ritem);
-- Conversion for Priority expression
if Nam = Name_Priority then
if Chars (Ritem) = Name_Priority
and then not GNAT_Mode
then
Exp := Convert_To (RTE (RE_Priority), Exp);
else
Exp :=
Convert_To (RTE (RE_Any_Priority), Exp);
end if;
end if;
end if;
-- Conversion for Dispatching_Domain value
if Nam = Name_Dispatching_Domain then
Exp :=
Unchecked_Convert_To
(RTE (RE_Dispatching_Domain_Access), Exp);
end if;
Actions := Build_Assignment (Id, Exp);
-- Nothing needed if no Rep Item
else
Actions := No_List;
end if;
end;
-- Composite component with its own Init_Proc
elsif not Is_Interface (Typ)

333
gcc/ada/exp_ch9.adb
View File

@ -395,15 +395,6 @@ package body Exp_Ch9 is
-- the scope of Context_Id and Context_Decls is the declarative list of
-- Context.
function Find_Task_Or_Protected_Pragma
(T : Node_Id;
P : Name_Id) return Node_Id;
-- Searches the task or protected definition T for the first occurrence
-- of the pragma whose name is given by P. The caller has ensured that
-- the pragma is present in the task definition. A special case is that
-- when P is Name_uPriority, the call will also find Interrupt_Priority.
-- ??? Should be implemented with the rep item chain mechanism.
function Index_Object (Spec_Id : Entity_Id) return Entity_Id;
-- Given a subprogram identifier, return the entity which is associated
-- with the protection entry index in the Protected_Body_Subprogram or the
@ -11279,30 +11270,30 @@ 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 present only if a Priority or Interrupt_Priority
-- pragma appears in the task definition. The expression captures the
-- argument that was present in the pragma, and is used to provide the Size
-- parameter to the call to Create_Task.
-- 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 _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 present only if a CPU pragma appears in the task
-- definition. The expression captures the argument that was present in
-- the pragma, and is used to provide the CPU 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 _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 present only if a Dispatching_Domain pragma or
-- aspect appears in the task definition. The expression captures the
-- argument that was present in the pragma or aspect, and is used to
-- provide the Dispatching_Domain 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).
-- When a task is declared, an instance of the task value record is
-- created. The elaboration of this declaration creates the correct bounds
@ -11336,20 +11327,64 @@ package body Exp_Ch9 is
procedure Expand_N_Task_Type_Declaration (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
TaskId : constant Entity_Id := Defining_Identifier (N);
Tasktyp : constant Entity_Id := Etype (Defining_Identifier (N));
Tasknm : constant Name_Id := Chars (Tasktyp);
Taskdef : constant Node_Id := Task_Definition (N);
Body_Decl : Node_Id;
Cdecls : List_Id;
Decl_Stack : Node_Id;
Elab_Decl : Node_Id;
Ent_Stack : Entity_Id;
Proc_Spec : Node_Id;
Rec_Decl : Node_Id;
Rec_Ent : Entity_Id;
Cdecls : List_Id;
Elab_Decl : Node_Id;
Size_Decl : Node_Id;
Body_Decl : Node_Id;
Size_Decl : Entity_Id;
Task_Size : Node_Id;
Ent_Stack : Entity_Id;
Decl_Stack : Node_Id;
function Get_Relative_Deadline_Pragma (T : Node_Id) return Node_Id;
-- Searches the task definition T for the first occurrence of the pragma
-- Relative Deadline. The caller has ensured that the pragma is present
-- in the task definition. Note that this routine cannot be implemented
-- with the Rep Item chain mechanism since Relative_Deadline pragmas are
-- not chained because their expansion into a procedure call statement
-- would cause a break in the chain.
----------------------------------
-- Get_Relative_Deadline_Pragma --
----------------------------------
function Get_Relative_Deadline_Pragma (T : Node_Id) return Node_Id is
N : Node_Id;
begin
N := First (Visible_Declarations (T));
while Present (N) loop
if Nkind (N) = N_Pragma
and then Pragma_Name (N) = Name_Relative_Deadline
then
return N;
end if;
Next (N);
end loop;
N := First (Private_Declarations (T));
while Present (N) loop
if Nkind (N) = N_Pragma
and then Pragma_Name (N) = Name_Relative_Deadline
then
return N;
end if;
Next (N);
end loop;
raise Program_Error;
end Get_Relative_Deadline_Pragma;
-- Start of processing for Expand_N_Task_Type_Declaration
begin
-- If already expanded, nothing to do
@ -11378,6 +11413,7 @@ package body Exp_Ch9 is
Aliased_Present => True,
Object_Definition => New_Reference_To (Standard_Boolean, Loc),
Expression => New_Reference_To (Standard_False, Loc));
Insert_After (N, Elab_Decl);
-- Next create the declaration of the size variable (tasknmZ)
@ -11392,8 +11428,7 @@ package body Exp_Ch9 is
Is_Static_Expression
(Expression
(First (Pragma_Argument_Associations
(Find_Task_Or_Protected_Pragma
(Taskdef, Name_Storage_Size)))))
(Get_Rep_Pragma (TaskId, Name_Storage_Size)))))
then
Size_Decl :=
Make_Object_Declaration (Loc,
@ -11403,8 +11438,8 @@ package body Exp_Ch9 is
Convert_To (RTE (RE_Size_Type),
Relocate_Node
(Expression (First (Pragma_Argument_Associations
(Find_Task_Or_Protected_Pragma
(Taskdef, Name_Storage_Size)))))));
(Get_Rep_Pragma
(TaskId, Name_Storage_Size)))))));
else
Size_Decl :=
@ -11472,8 +11507,7 @@ package body Exp_Ch9 is
Expr_N : constant Node_Id :=
Expression (First (
Pragma_Argument_Associations (
Find_Task_Or_Protected_Pragma
(Taskdef, Name_Storage_Size))));
Get_Rep_Pragma (TaskId, Name_Storage_Size))));
Etyp : constant Entity_Id := Etype (Expr_N);
P : constant Node_Id := Parent (Expr_N);
@ -11532,36 +11566,7 @@ package body Exp_Ch9 is
Collect_Entry_Families (Loc, Cdecls, Size_Decl, Tasktyp);
-- Add the _Priority component if a Priority pragma is present
if Present (Taskdef) and then Has_Pragma_Priority (Taskdef) then
declare
Prag : constant Node_Id :=
Find_Task_Or_Protected_Pragma (Taskdef, Name_Priority);
Expr : Node_Id;
begin
Expr := First (Pragma_Argument_Associations (Prag));
if Nkind (Expr) = N_Pragma_Argument_Association then
Expr := Expression (Expr);
end if;
Expr := New_Copy_Tree (Expr);
-- Add conversion to proper type to do range check if required
-- Note that for runtime units, we allow out of range interrupt
-- priority values to be used in a priority pragma. This is for
-- the benefit of some versions of System.Interrupts which use
-- a special server task with maximum interrupt priority.
if Pragma_Name (Prag) = Name_Priority
and then not GNAT_Mode
then
Rewrite (Expr, Convert_To (RTE (RE_Priority), Expr));
else
Rewrite (Expr, Convert_To (RTE (RE_Any_Priority), Expr));
end if;
-- Add the _Priority component with no expression
Append_To (Cdecls,
Make_Component_Declaration (Loc,
@ -11570,13 +11575,10 @@ package body Exp_Ch9 is
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication => New_Reference_To (Standard_Integer,
Loc)),
Expression => Expr));
end;
end if;
Subtype_Indication =>
New_Reference_To (Standard_Integer, Loc))));
-- Add the _Task_Size component if a Storage_Size pragma is present
-- Add the _Size component if a Storage_Size pragma is present
if Present (Taskdef)
and then Has_Storage_Size_Pragma (Taskdef)
@ -11589,21 +11591,20 @@ package body Exp_Ch9 is
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication => New_Reference_To (RTE (RE_Size_Type),
Loc)),
Subtype_Indication =>
New_Reference_To (RTE (RE_Size_Type), Loc)),
Expression =>
Convert_To (RTE (RE_Size_Type),
Relocate_Node (
Expression (First (
Pragma_Argument_Associations (
Find_Task_Or_Protected_Pragma
(Taskdef, Name_Storage_Size))))))));
Get_Rep_Pragma (TaskId, Name_Storage_Size))))))));
end if;
-- Add the _Task_Info component if a Task_Info pragma is present
if Present (Taskdef) and then Has_Task_Info_Pragma (Taskdef) then
if Has_Rep_Pragma_For_Entity (TaskId, Name_Task_Info) then
Append_To (Cdecls,
Make_Component_Declaration (Loc,
Defining_Identifier =>
@ -11618,13 +11619,11 @@ package body Exp_Ch9 is
Expression => New_Copy (
Expression (First (
Pragma_Argument_Associations (
Find_Task_Or_Protected_Pragma
(Taskdef, Name_Task_Info)))))));
Get_Rep_Pragma_For_Entity (TaskId, Name_Task_Info)))))));
end if;
-- Add the _CPU component if a CPU pragma is present
-- Add the _CPU component with no expression
if Present (Taskdef) and then Has_Pragma_CPU (Taskdef) then
Append_To (Cdecls,
Make_Component_Declaration (Loc,
Defining_Identifier =>
@ -11634,14 +11633,7 @@ package body Exp_Ch9 is
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication =>
New_Reference_To (RTE (RE_CPU_Range), Loc)),
Expression => New_Copy (
Expression (First (
Pragma_Argument_Associations (
Find_Task_Or_Protected_Pragma
(Taskdef, Name_CPU)))))));
end if;
New_Reference_To (RTE (RE_CPU_Range), Loc))));
-- Add the _Relative_Deadline component if a Relative_Deadline pragma is
-- present. If we are using a restricted run time this component will
@ -11667,19 +11659,14 @@ package body Exp_Ch9 is
Relocate_Node (
Expression (First (
Pragma_Argument_Associations (
Find_Task_Or_Protected_Pragma
(Taskdef, Name_Relative_Deadline))))))));
Get_Relative_Deadline_Pragma (Taskdef))))))));
end if;
-- Add the _Dispatching_Domain component if a Dispatching_Domain pragma
-- or aspect 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).
-- 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).
if not Restricted_Profile
and then Present (Taskdef)
and then Has_Pragma_Dispatching_Domain (Taskdef)
then
if not Restricted_Profile then
Append_To (Cdecls,
Make_Component_Declaration (Loc,
Defining_Identifier =>
@ -11690,16 +11677,7 @@ package body Exp_Ch9 is
Aliased_Present => False,
Subtype_Indication =>
New_Reference_To
(RTE (RE_Dispatching_Domain_Access), Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Dispatching_Domain_Access),
Relocate_Node
(Expression
(First
(Pragma_Argument_Associations
(Find_Task_Or_Protected_Pragma
(Taskdef, Name_Dispatching_Domain))))))));
(RTE (RE_Dispatching_Domain_Access), Loc))));
end if;
Insert_After (Size_Decl, Rec_Decl);
@ -12750,60 +12728,6 @@ package body Exp_Ch9 is
return S;
end Find_Master_Scope;
-----------------------------------
-- Find_Task_Or_Protected_Pragma --
-----------------------------------
function Find_Task_Or_Protected_Pragma
(T : Node_Id;
P : Name_Id) return Node_Id
is
N : Node_Id;
begin
N := First (Visible_Declarations (T));
while Present (N) loop
if Nkind (N) = N_Pragma then
if Pragma_Name (N) = P then
return N;
elsif P = Name_Priority
and then Pragma_Name (N) = Name_Interrupt_Priority
then
return N;
else
Next (N);
end if;
else
Next (N);
end if;
end loop;
N := First (Private_Declarations (T));
while Present (N) loop
if Nkind (N) = N_Pragma then
if Pragma_Name (N) = P then
return N;
elsif P = Name_Priority
and then Pragma_Name (N) = Name_Interrupt_Priority
then
return N;
else
Next (N);
end if;
else
Next (N);
end if;
end loop;
raise Program_Error;
end Find_Task_Or_Protected_Pragma;
-------------------------------
-- First_Protected_Operation --
-------------------------------
@ -13362,7 +13286,6 @@ package body Exp_Ch9 is
is
Loc : constant Source_Ptr := Sloc (Protect_Rec);
P_Arr : Entity_Id;
Pdef : Node_Id;
Pdec : Node_Id;
Ptyp : constant Node_Id :=
Corresponding_Concurrent_Type (Protect_Rec);
@ -13392,10 +13315,6 @@ package body Exp_Ch9 is
Next (Pdec);
end loop;
-- Now we can find the object definition from this declaration
Pdef := Protected_Definition (Pdec);
-- Build the parameter list for the call. Note that _Init is the name
-- of the formal for the object to be initialized, which is the task
-- value record itself.
@ -13418,24 +13337,34 @@ package body Exp_Ch9 is
Attribute_Name => Name_Unchecked_Access));
-- Priority parameter. Set to Unspecified_Priority unless there is a
-- priority pragma, in which case we take the value from the pragma,
-- or there is an interrupt pragma and no priority pragma, and we
-- set the ceiling to Interrupt_Priority'Last, an implementation-
-- defined value, see D.3(10).
-- priority clause, in which case we take the value from the
-- pragma/attribute definition clause, or there is an interrupt
-- clause and no priority clause, and we set the ceiling to
-- Interrupt_Priority'Last, an implementation defined value,
-- see D.3(10).
if Present (Pdef)
and then Has_Pragma_Priority (Pdef)
then
if Has_Rep_Item (Ptyp, Name_Priority) then
declare
Prio : constant Node_Id :=
Expression
(First
(Pragma_Argument_Associations
(Find_Task_Or_Protected_Pragma
(Pdef, Name_Priority))));
Prio_Clause : constant Node_Id :=
Get_Rep_Item (Ptyp, Name_Priority);
Prio : Node_Id;
Temp : Entity_Id;
begin
-- Pragma Priority
if Nkind (Prio_Clause) = N_Pragma then
Prio :=
Expression
(First (Pragma_Argument_Associations (Prio_Clause)));
-- Attribute definition clause Priority
else
Prio := Expression (Prio_Clause);
end if;
-- If priority is a static expression, then we can duplicate it
-- with no problem and simply append it to the argument list.
@ -13738,9 +13667,9 @@ package body Exp_Ch9 is
Args := New_List;
-- Priority parameter. Set to Unspecified_Priority unless there is a
-- priority pragma, in which case we take the value from the pragma.
-- priority rep item, in which case we take the value from the rep item.
if Present (Tdef) and then Has_Pragma_Priority (Tdef) then
if Has_Rep_Item (Ttyp, Name_Priority) then
Append_To (Args,
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
@ -13795,9 +13724,7 @@ package body Exp_Ch9 is
-- Task_Info parameter. Set to Unspecified_Task_Info unless there is a
-- Task_Info pragma, in which case we take the value from the pragma.
if Present (Tdef)
and then Has_Task_Info_Pragma (Tdef)
then
if Has_Rep_Pragma_For_Entity (Ttyp, Name_Task_Info) then
Append_To (Args,
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
@ -13808,18 +13735,17 @@ package body Exp_Ch9 is
New_Reference_To (RTE (RE_Unspecified_Task_Info), Loc));
end if;
-- CPU parameter. Set to Unspecified_CPU unless there is a CPU pragma,
-- in which case we take the value from the pragma. The parameter is
-- CPU parameter. Set to Unspecified_CPU unless there is a CPU rep item,
-- in which case we take the value from the rep item. The parameter is
-- passed as an Integer because in the case of unspecified CPU the
-- value is not in the range of CPU_Range.
if Present (Tdef) and then Has_Pragma_CPU (Tdef) then
if Has_Rep_Item (Ttyp, Name_CPU) then
Append_To (Args,
Convert_To (Standard_Integer,
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name => Make_Identifier (Loc, Name_uCPU))));
else
Append_To (Args,
New_Reference_To (RTE (RE_Unspecified_CPU), Loc));
@ -13836,7 +13762,9 @@ package body Exp_Ch9 is
-- Case where pragma Relative_Deadline applies: use given value
if Present (Tdef) and then Has_Relative_Deadline_Pragma (Tdef) then
if Present (Tdef)
and then Has_Relative_Deadline_Pragma (Tdef)
then
Append_To (Args,
Make_Selected_Component (Loc,
Prefix =>
@ -13851,18 +13779,17 @@ package body Exp_Ch9 is
New_Reference_To (RTE (RE_Time_Span_Zero), Loc));
end if;
-- Dispatching_Domain parameter. If no Dispatching_Domain pragma or
-- aspect is present, then the dispatching domain is null. If a
-- pragma or aspect is present, then the dispatching domain is taken
-- from the _Dispatching_Domain field of the task value record,
-- which was set from the pragma value. Note that this parameter
-- must not be generated for the restricted profiles since Ravenscar
-- does not allow dispatching domains.
-- Dispatching_Domain parameter. If no Dispatching_Domain rep item is
-- present, then the dispatching domain is null. If a rep item is
-- present, then the dispatching domain is taken from the
-- _Dispatching_Domain field of the task value record, which was set
-- from the rep item value. Note that this parameter must not be
-- generated for the restricted profiles since Ravenscar does not
-- allow dispatching domains.
-- Case where pragma or aspect Dispatching_Domain applies: use given
-- value.
-- Case where Dispatching_Domain rep item applies: use given value
if Present (Tdef) and then Has_Pragma_Dispatching_Domain (Tdef) then
if Has_Rep_Item (Ttyp, Name_Dispatching_Domain) then
Append_To (Args,
Make_Selected_Component (Loc,
Prefix =>
@ -13980,18 +13907,16 @@ package body Exp_Ch9 is
-- init call unless there is a Task_Name pragma, in which case we take
-- the value from the pragma.
if Present (Tdef)
and then Has_Task_Name_Pragma (Tdef)
then
if Has_Rep_Pragma_For_Entity (Ttyp, Name_Task_Name) then
-- Copy expression in full, because it may be dynamic and have
-- side effects.
Append_To (Args,
New_Copy_Tree
(Expression (First
(Expression
(First
(Pragma_Argument_Associations
(Find_Task_Or_Protected_Pragma
(Tdef, Name_Task_Name))))));
(Get_Rep_Pragma_For_Entity (Ttyp, Name_Task_Name))))));
else
Append_To (Args, Make_Identifier (Loc, Name_uTask_Name));

55
gcc/ada/freeze.adb
View File

@ -49,6 +49,7 @@ with Sem_Cat; use Sem_Cat;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch9; use Sem_Ch9;
with Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
with Sem_Mech; use Sem_Mech;
@ -1323,6 +1324,11 @@ package body Freeze is
-- for a description of how we handle aspect visibility).
elsif Has_Delayed_Aspects (E) then
-- Retrieve the visibility to the discriminants in order to
-- analyze properly the aspects.
Push_Scope_And_Install_Discriminants (E);
declare
Ritem : Node_Id;
@ -1339,6 +1345,8 @@ package body Freeze is
Ritem := Next_Rep_Item (Ritem);
end loop;
end;
Uninstall_Discriminants_And_Pop_Scope (E);
end if;
-- If an incomplete type is still not frozen, this may be a
@ -1536,6 +1544,10 @@ package body Freeze is
procedure Add_To_Result (N : Node_Id);
-- N is a freezing action to be appended to the Result
function After_Last_Declaration return Boolean;
-- If Loc is a freeze_entity that appears after the last declaration
-- in the scope, inhibit error messages on late completion.
procedure Check_Current_Instance (Comp_Decl : Node_Id);
-- Check that an Access or Unchecked_Access attribute with a prefix
-- which is the current instance type can only be applied when the type
@ -1546,10 +1558,6 @@ package body Freeze is
-- integer literal without an explicit corresponding size clause. The
-- caller has checked that Utype is a modular integer type.
function After_Last_Declaration return Boolean;
-- If Loc is a freeze_entity that appears after the last declaration
-- in the scope, inhibit error messages on late completion.
procedure Freeze_Record_Type (Rec : Entity_Id);
-- Freeze each component, handle some representation clauses, and freeze
-- primitive operations if this is a tagged type.
@ -2513,39 +2521,15 @@ package body Freeze is
end;
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 this point.
-- 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
-- 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
declare
Ritem : Node_Id;
Aitem : Node_Id;
begin
-- Look for aspect specification entries for this entity
Ritem := First_Rep_Item (E);
while Present (Ritem) loop
if Nkind (Ritem) = N_Aspect_Specification
and then Entity (Ritem) = E
and then Is_Delayed_Aspect (Ritem)
and then Scope (E) = Current_Scope
then
Aitem := Aspect_Rep_Item (Ritem);
-- Skip if this is an aspect with no corresponding pragma
-- or attribute definition node (such as Default_Value).
if Present (Aitem) then
Set_Parent (Aitem, Ritem);
Analyze (Aitem);
end if;
end if;
Next_Rep_Item (Ritem);
end loop;
end;
Evaluate_Aspects_At_Freeze_Point (E);
end if;
-- Here to freeze the entity
@ -2555,7 +2539,6 @@ package body Freeze is
-- Case of entity being frozen is other than a type
if not Is_Type (E) then
-- If entity is exported or imported and does not have an external
-- name, now is the time to provide the appropriate default name.
-- Skip this if the entity is stubbed, since we don't need a name

24
gcc/ada/sem_attr.adb
View File

@ -2215,6 +2215,14 @@ package body Sem_Attr is
Attribute_Variable_Indexing =>
Error_Msg_N ("illegal attribute", N);
-- Attributes related to Ada 2012 aspects. Attribute definition clause
-- exists for these, but they cannot be queried.
when Attribute_CPU |
Attribute_Dispatching_Domain |
Attribute_Interrupt_Priority =>
Error_Msg_N ("illegal attribute", N);
------------------
-- Abort_Signal --
------------------
@ -6286,11 +6294,17 @@ package body Sem_Attr is
-- Attributes related to Ada 2012 iterators (placeholder ???)
when Attribute_Constant_Indexing => null;
when Attribute_Default_Iterator => null;
when Attribute_Implicit_Dereference => null;
when Attribute_Iterator_Element => null;
when Attribute_Variable_Indexing => null;
when Attribute_Constant_Indexing |
Attribute_Default_Iterator |
Attribute_Implicit_Dereference |
Attribute_Iterator_Element |
Attribute_Variable_Indexing => null;
-- Atributes related to Ada 2012 aspects
when Attribute_CPU |
Attribute_Dispatching_Domain |
Attribute_Interrupt_Priority => null;
--------------
-- Adjacent --

13
gcc/ada/sem_aux.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1992-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- --
@ -832,7 +832,7 @@ package body Sem_Aux is
----------------------
function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id is
D : constant Node_Id := Declaration_Node (Typ);
D : constant Node_Id := Original_Node (Declaration_Node (Typ));
begin
-- If we have a subtype declaration, get the ancestor subtype
@ -860,6 +860,15 @@ package body Sem_Aux is
end if;
end;
-- If derived type and private type, get the full view to find who we
-- are derived from.
elsif Is_Derived_Type (Typ)
and then Is_Private_Type (Typ)
and then Present (Full_View (Typ))
then
return Nearest_Ancestor (Full_View (Typ));
-- Otherwise, nothing useful to return, return Empty
else

1467
gcc/ada/sem_ch13.adb
View File

File diff suppressed because it is too large Load Diff

8
gcc/ada/sem_ch13.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- Copyright (C) 1992-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- --
@ -237,7 +237,7 @@ package Sem_Ch13 is
-- The visibility of aspects is tricky. First, the visibility is delayed
-- to the freeze point. This is not too complicated, what we do is simply
-- to leave the aspect "laying in wait" for the freeze point, and at that
-- point materialize and analye the corresponding attribute definition
-- point materialize and analyze the corresponding attribute definition
-- clause or pragma. There is some special processing for preconditions
-- and postonditions, where the pragmas themselves deal with the required
-- delay, but basically the approach is the same, delay analysis of the
@ -307,4 +307,8 @@ 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);
-- This routines evaluates all the delayed aspects for entity E at freezing
-- point.
end Sem_Ch13;

91
gcc/ada/sem_ch9.adb
View File

@ -111,10 +111,6 @@ package body Sem_Ch9 is
-- Find entity in corresponding task or protected declaration. Use full
-- view if first declaration was for an incomplete type.
procedure Install_Declarations (Spec : Entity_Id);
-- Utility to make visible in corresponding body the entities defined in
-- task, protected type declaration, or entry declaration.
-------------------------------------
-- Allows_Lock_Free_Implementation --
-------------------------------------
@ -2983,4 +2979,91 @@ package body Sem_Ch9 is
end loop;
end Install_Declarations;
---------------------------
-- Install_Discriminants --
---------------------------
procedure Install_Discriminants (E : Entity_Id) is
Disc : Entity_Id;
Prev : Entity_Id;
begin
Disc := First_Discriminant (E);
while Present (Disc) loop
Prev := Current_Entity (Disc);
Set_Current_Entity (Disc);
Set_Is_Immediately_Visible (Disc);
Set_Homonym (Disc, Prev);
Next_Discriminant (Disc);
end loop;
end Install_Discriminants;
------------------------------------------
-- Push_Scope_And_Install_Discriminants --
------------------------------------------
procedure Push_Scope_And_Install_Discriminants (E : Entity_Id) is
begin
if Has_Discriminants (E) then
Push_Scope (E);
Install_Discriminants (E);
end if;
end Push_Scope_And_Install_Discriminants;
-----------------------------
-- Uninstall_Discriminants --
-----------------------------
procedure Uninstall_Discriminants (E : Entity_Id) is
Disc : Entity_Id;
Prev : Entity_Id;
Outer : Entity_Id;
begin
Disc := First_Discriminant (E);
while Present (Disc) loop
if Disc /= Current_Entity (Disc) then
Prev := Current_Entity (Disc);
while Present (Prev)
and then Present (Homonym (Prev))
and then Homonym (Prev) /= Disc
loop
Prev := Homonym (Prev);
end loop;
else
Prev := Empty;
end if;
Set_Is_Immediately_Visible (Disc, False);
Outer := Homonym (Disc);
while Present (Outer) and then Scope (Outer) = E loop
Outer := Homonym (Outer);
end loop;
-- Reset homonym link of other entities, but do not modify link
-- between entities in current scope, so that the back-end can have
-- a proper count of local overloadings.
if No (Prev) then
Set_Name_Entity_Id (Chars (Disc), Outer);
elsif Scope (Prev) /= Scope (Disc) then
Set_Homonym (Prev, Outer);
end if;
Next_Discriminant (Disc);
end loop;
end Uninstall_Discriminants;
-------------------------------------------
-- Uninstall_Discriminants_And_Pop_Scope --
-------------------------------------------
procedure Uninstall_Discriminants_And_Pop_Scope (E : Entity_Id) is
begin
if Has_Discriminants (E) then
Uninstall_Discriminants (E);
Pop_Scope;
end if;
end Uninstall_Discriminants_And_Pop_Scope;
end Sem_Ch9;

19
gcc/ada/sem_ch9.ads
View File

@ -54,6 +54,25 @@ package Sem_Ch9 is
procedure Analyze_Timed_Entry_Call (N : Node_Id);
procedure Analyze_Triggering_Alternative (N : Node_Id);
procedure Install_Declarations (Spec : Entity_Id);
-- Utility to make visible in corresponding body the entities defined in
-- task, protected type declaration, or entry declaration.
procedure Install_Discriminants (E : Entity_Id);
-- Utility to make visible the discriminants of type entity E
procedure Push_Scope_And_Install_Discriminants (E : Entity_Id);
-- Utility that pushes the scope E and makes visible the discriminants of
-- type entity E if E has discriminants.
procedure Uninstall_Discriminants (E : Entity_Id);
-- Utility that removes the visibility to the discriminants of type entity
-- E.
procedure Uninstall_Discriminants_And_Pop_Scope (E : Entity_Id);
-- Utility that removes the visibility to the discriminants of type entity
-- E and pop the scope stack if E has discriminants.
------------------------------
-- Lock Free Data Structure --
------------------------------

161
gcc/ada/sem_prag.adb
View File

@ -571,10 +571,9 @@ package body Sem_Prag is
-- error message for bad placement is given.
procedure Check_Duplicate_Pragma (E : Entity_Id);
-- Check if a pragma of the same name as the current pragma is already
-- Check if a rep item of the same name as the current pragma is already
-- chained as a rep pragma to the given entity. If so give a message
-- about the duplicate, and then raise Pragma_Exit so does not return.
-- Also checks for delayed aspect specification node in the chain.
procedure Check_Duplicated_Export_Name (Nam : Node_Id);
-- Nam is an N_String_Literal node containing the external name set by
@ -1598,6 +1597,7 @@ package body Sem_Prag is
----------------------------
procedure Check_Duplicate_Pragma (E : Entity_Id) is
Id : Entity_Id := E;
P : Node_Id;
begin
@ -1610,7 +1610,8 @@ package body Sem_Prag is
end if;
-- Otherwise current pragma may duplicate previous pragma or a
-- previously given aspect specification for the same pragma.
-- previously given aspect specification or attribute definition
-- clause for the same pragma.
P := Get_Rep_Item_For_Entity (E, Pragma_Name (N));
@ -1618,12 +1619,25 @@ package body Sem_Prag is
Error_Msg_Name_1 := Pragma_Name (N);
Error_Msg_Sloc := Sloc (P);
-- For a single protected or a single task object, the error is
-- issued on the original entity.
if Ekind (Id) = E_Task_Type
or else Ekind (Id) = E_Protected_Type
then
Id := Defining_Identifier (Original_Node (Parent (Id)));
end if;
if Nkind (P) = N_Aspect_Specification
or else From_Aspect_Specification (P)
then
Error_Msg_NE ("aspect% for & previously given#", N, E);
Error_Msg_NE ("aspect% for & previously given#", N, Id);
elsif Nkind (P) = N_Pragma then
Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
else
Error_Msg_NE ("pragma% for & duplicates pragma#", N, E);
Error_Msg_NE ("pragma% for & duplicates clause#", N, Id);
end if;
raise Pragma_Exit;
@ -2917,7 +2931,7 @@ package body Sem_Prag is
end Pragma_Misplaced;
------------------------------------
-- Process Atomic_Shared_Volatile --
-- Process_Atomic_Shared_Volatile --
------------------------------------
procedure Process_Atomic_Shared_Volatile is
@ -6597,6 +6611,7 @@ package body Sem_Prag is
end if;
Set_Is_Ada_2005_Only (Entity (E_Id));
Record_Rep_Item (Entity (E_Id), N);
else
Check_Arg_Count (0);
@ -6644,6 +6659,7 @@ package body Sem_Prag is
end if;
Set_Is_Ada_2012_Only (Entity (E_Id));
Record_Rep_Item (Entity (E_Id), N);
else
Check_Arg_Count (0);
@ -7149,6 +7165,7 @@ package body Sem_Prag is
Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
end if;
end Atomic_Components;
--------------------
-- Attach_Handler --
--------------------
@ -7931,6 +7948,7 @@ package body Sem_Prag is
when Pragma_CPU => CPU : declare
P : constant Node_Id := Parent (N);
Arg : Node_Id;
Ent : Entity_Id;
begin
Ada_2012_Pragma;
@ -7945,6 +7963,12 @@ package body Sem_Prag is
Arg := Get_Pragma_Arg (Arg1);
Analyze_And_Resolve (Arg, Any_Integer);
Ent := Defining_Unit_Name (Specification (P));
if Nkind (Ent) = N_Defining_Program_Unit_Name then
Ent := Defining_Identifier (Ent);
end if;
-- Must be static
if not Is_Static_Expression (Arg) then
@ -7984,6 +8008,7 @@ package body Sem_Prag is
elsif Nkind (P) = N_Task_Definition then
Arg := Get_Pragma_Arg (Arg1);
Ent := Defining_Identifier (Parent (P));
-- The expression must be analyzed in the special manner
-- described in "Handling of Default and Per-Object
@ -7997,15 +8022,12 @@ package body Sem_Prag is
Pragma_Misplaced;
end if;
if Has_Pragma_CPU (P) then
Error_Pragma ("duplicate pragma% not allowed");
else
Set_Has_Pragma_CPU (P, True);
-- Check duplicate pragma before we chain the pragma in the Rep
-- Item chain of Ent.
if Nkind (P) = N_Task_Definition then
Record_Rep_Item (Defining_Identifier (Parent (P)), N);
end if;
end if;
Check_Duplicate_Pragma (Ent);
Record_Rep_Item (Ent, N);
end CPU;
-----------
@ -8249,6 +8271,8 @@ package body Sem_Prag is
or else Ekind (E) = E_Exception
then
Set_Discard_Names (E);
Record_Rep_Item (E, N);
else
Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1);
@ -8267,6 +8291,7 @@ package body Sem_Prag is
when Pragma_Dispatching_Domain => Dispatching_Domain : declare
P : constant Node_Id := Parent (N);
Arg : Node_Id;
Ent : Entity_Id;
begin
Ada_2012_Pragma;
@ -8282,6 +8307,7 @@ package body Sem_Prag is
if Nkind (P) = N_Task_Definition then
Arg := Get_Pragma_Arg (Arg1);
Ent := Defining_Identifier (Parent (P));
-- The expression must be analyzed in the special manner
-- described in "Handling of Default and Per-Object
@ -8289,21 +8315,18 @@ package body Sem_Prag is
Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
-- Check duplicate pragma before we chain the pragma in the Rep
-- Item chain of Ent.
Check_Duplicate_Pragma (Ent);
Record_Rep_Item (Ent, N);
-- Anything else is incorrect
else
Pragma_Misplaced;
end if;
if Has_Pragma_Dispatching_Domain (P) then
Error_Pragma ("duplicate pragma% not allowed");
else
Set_Has_Pragma_Dispatching_Domain (P, True);
if Nkind (P) = N_Task_Definition then
Record_Rep_Item (Defining_Identifier (Parent (P)), N);
end if;
end if;
end Dispatching_Domain;
---------------
@ -10235,6 +10258,7 @@ package body Sem_Prag is
when Pragma_Interrupt_Priority => Interrupt_Priority : declare
P : constant Node_Id := Parent (N);
Arg : Node_Id;
Ent : Entity_Id;
begin
Check_Ada_83_Warning;
@ -10255,12 +10279,15 @@ package body Sem_Prag is
Pragma_Misplaced;
return;
elsif Has_Pragma_Priority (P) then
Error_Pragma ("duplicate pragma% not allowed");
else
Set_Has_Pragma_Priority (P, True);
Record_Rep_Item (Defining_Identifier (Parent (P)), N);
Ent := Defining_Identifier (Parent (P));
-- Check duplicate pragma before we chain the pragma in the Rep
-- Item chain of Ent.
Check_Duplicate_Pragma (Ent);
Record_Rep_Item (Ent, N);
end if;
end Interrupt_Priority;
@ -12295,6 +12322,7 @@ package body Sem_Prag is
when Pragma_Priority => Priority : declare
P : constant Node_Id := Parent (N);
Arg : Node_Id;
Ent : Entity_Id;
begin
Check_No_Identifiers;
@ -12305,6 +12333,12 @@ package body Sem_Prag is
if Nkind (P) = N_Subprogram_Body then
Check_In_Main_Program;
Ent := Defining_Unit_Name (Specification (P));
if Nkind (Ent) = N_Defining_Program_Unit_Name then
Ent := Defining_Identifier (Ent);
end if;
Arg := Get_Pragma_Arg (Arg1);
Analyze_And_Resolve (Arg, Standard_Integer);
@ -12356,6 +12390,7 @@ package body Sem_Prag is
elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
Arg := Get_Pragma_Arg (Arg1);
Ent := Defining_Identifier (Parent (P));
-- The expression must be analyzed in the special manner
-- described in "Handling of Default and Per-Object
@ -12373,16 +12408,12 @@ package body Sem_Prag is
Pragma_Misplaced;
end if;
if Has_Pragma_Priority (P) then
Error_Pragma ("duplicate pragma% not allowed");
else
Set_Has_Pragma_Priority (P, True);
-- Check duplicate pragma before we chain the pragma in the Rep
-- Item chain of Ent.
if Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
Record_Rep_Item (Defining_Identifier (Parent (P)), N);
-- exp_ch9 should use this ???
end if;
end if;
Check_Duplicate_Pragma (Ent);
Record_Rep_Item (Ent, N);
end Priority;
-----------------------------------
@ -12968,26 +12999,24 @@ package body Sem_Prag is
if Nkind (P) = N_Subprogram_Body then
Check_In_Main_Program;
-- Tasks
-- Only Task and subprogram cases allowed
elsif Nkind (P) = N_Task_Definition then
null;
-- Anything else is incorrect
else
elsif Nkind (P) /= N_Task_Definition then
Pragma_Misplaced;
end if;
-- Check duplicate pragma before we set the corresponding flag
if Has_Relative_Deadline_Pragma (P) then
Error_Pragma ("duplicate pragma% not allowed");
else
Set_Has_Relative_Deadline_Pragma (P, True);
end if;
if Nkind (P) = N_Task_Definition then
Record_Rep_Item (Defining_Identifier (Parent (P)), N);
end if;
end if;
-- Set Has_Relative_Deadline_Pragma only for tasks. Note that
-- Relative_Deadline pragma node cannot be inserted in the Rep
-- Item chain of Ent since it is rewritten by the expander as a
-- procedure call statement that will break the chain.
Set_Has_Relative_Deadline_Pragma (P, True);
end Relative_Deadline;
------------------------
@ -13458,7 +13487,6 @@ package body Sem_Prag is
end if;
Record_Rep_Item (Defining_Identifier (Parent (P)), N);
-- ??? exp_ch9 should use this!
end if;
end Storage_Size;
@ -13878,6 +13906,7 @@ package body Sem_Prag is
when Pragma_Task_Info => Task_Info : declare
P : constant Node_Id := Parent (N);
Ent : Entity_Id;
begin
GNAT_Pragma;
@ -13896,11 +13925,13 @@ package body Sem_Prag is
return;
end if;
if Has_Task_Info_Pragma (P) then
Error_Pragma ("duplicate pragma% not allowed");
else
Set_Has_Task_Info_Pragma (P, True);
end if;
Ent := Defining_Identifier (Parent (P));
-- Check duplicate pragma before we chain the pragma in the Rep
-- Item chain of Ent.
Check_Duplicate_Pragma (Ent);
Record_Rep_Item (Ent, N);
end Task_Info;
---------------
@ -13912,6 +13943,7 @@ package body Sem_Prag is
when Pragma_Task_Name => Task_Name : declare
P : constant Node_Id := Parent (N);
Arg : Node_Id;
Ent : Entity_Id;
begin
Check_No_Identifiers;
@ -13930,12 +13962,13 @@ package body Sem_Prag is
Pragma_Misplaced;
end if;
if Has_Task_Name_Pragma (P) then
Error_Pragma ("duplicate pragma% not allowed");
else
Set_Has_Task_Name_Pragma (P, True);
Record_Rep_Item (Defining_Identifier (Parent (P)), N);
end if;
Ent := Defining_Identifier (Parent (P));
-- Check duplicate pragma before we chain the pragma in the Rep
-- Item chain of Ent.
Check_Duplicate_Pragma (Ent);
Record_Rep_Item (Ent, N);
end Task_Name;
------------------
@ -14143,6 +14176,7 @@ package body Sem_Prag is
Check_Arg_Is_Local_Name (Arg1);
Find_Type (Type_Id);
Typ := Entity (Type_Id);
if Typ = Any_Type
@ -14287,6 +14321,7 @@ package body Sem_Prag is
end if;
Set_Universal_Aliasing (Implementation_Base_Type (E_Id));
Record_Rep_Item (E_Id, N);
end Universal_Alias;
--------------------

25
gcc/ada/sem_util.adb
View File

@ -2259,10 +2259,35 @@ package body Sem_Util is
end if;
if Wmsg then
-- Check whether the context is an Init_Proc
if Inside_Init_Proc then
declare
Conc_Typ : constant Entity_Id :=
Corresponding_Concurrent_Type
(Entity (Parameter_Type (First
(Parameter_Specifications
(Parent (Current_Scope))))));
begin
-- Don't complain if the corresponding concurrent type
-- doesn't come from source (i.e. a single task/protected
-- object).
if Present (Conc_Typ)
and then not Comes_From_Source (Conc_Typ)
then
Error_Msg_NEL
("\?& will be raised at run time",
N, Standard_Constraint_Error, Eloc);
else
Error_Msg_NEL
("\?& will be raised for objects of this type",
N, Standard_Constraint_Error, Eloc);
end if;
end;
else
Error_Msg_NEL
("\?& will be raised at run time",

86
gcc/ada/sinfo.adb
View File

@ -1476,33 +1476,6 @@ package body Sinfo is
return Flag17 (N);
end Has_No_Elaboration_Code;
function Has_Pragma_CPU
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Subprogram_Body
or else NT (N).Nkind = N_Task_Definition);
return Flag14 (N);
end Has_Pragma_CPU;
function Has_Pragma_Dispatching_Domain
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Task_Definition);
return Flag15 (N);
end Has_Pragma_Dispatching_Domain;
function Has_Pragma_Priority
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Protected_Definition
or else NT (N).Nkind = N_Subprogram_Body
or else NT (N).Nkind = N_Task_Definition);
return Flag6 (N);
end Has_Pragma_Priority;
function Has_Pragma_Suppress_All
(N : Node_Id) return Boolean is
begin
@ -1549,22 +1522,6 @@ package body Sinfo is
return Flag5 (N);
end Has_Storage_Size_Pragma;
function Has_Task_Info_Pragma
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Task_Definition);
return Flag7 (N);
end Has_Task_Info_Pragma;
function Has_Task_Name_Pragma
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Task_Definition);
return Flag8 (N);
end Has_Task_Name_Pragma;
function Has_Wide_Character
(N : Node_Id) return Boolean is
begin
@ -4580,33 +4537,6 @@ package body Sinfo is
Set_Flag17 (N, Val);
end Set_Has_No_Elaboration_Code;
procedure Set_Has_Pragma_CPU
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Subprogram_Body
or else NT (N).Nkind = N_Task_Definition);
Set_Flag14 (N, Val);
end Set_Has_Pragma_CPU;
procedure Set_Has_Pragma_Dispatching_Domain
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Task_Definition);
Set_Flag15 (N, Val);
end Set_Has_Pragma_Dispatching_Domain;
procedure Set_Has_Pragma_Priority
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Protected_Definition
or else NT (N).Nkind = N_Subprogram_Body
or else NT (N).Nkind = N_Task_Definition);
Set_Flag6 (N, Val);
end Set_Has_Pragma_Priority;
procedure Set_Has_Pragma_Suppress_All
(N : Node_Id; Val : Boolean := True) is
begin
@ -4653,22 +4583,6 @@ package body Sinfo is
Set_Flag5 (N, Val);
end Set_Has_Storage_Size_Pragma;
procedure Set_Has_Task_Info_Pragma
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Task_Definition);
Set_Flag7 (N, Val);
end Set_Has_Task_Info_Pragma;
procedure Set_Has_Task_Name_Pragma
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Task_Definition);
Set_Flag8 (N, Val);
end Set_Has_Task_Name_Pragma;
procedure Set_Has_Wide_Character
(N : Node_Id; Val : Boolean := True) is
begin

72
gcc/ada/sinfo.ads
View File

@ -1149,16 +1149,6 @@ package Sinfo is
-- generate elaboration code, and non-preelaborated packages which do
-- not generate elaboration code.
-- Has_Pragma_CPU (Flag14-Sem)
-- A flag present in N_Subprogram_Body and N_Task_Definition nodes to
-- flag the presence of a CPU pragma in the declaration sequence (public
-- or private in the task case).
-- Has_Pragma_Dispatching_Domain (Flag15-Sem)
-- A flag present in N_Task_Definition nodes to flag the presence of a
-- Dispatching_Domain pragma in the declaration sequence (public or
-- private in the task case).
-- Has_Pragma_Suppress_All (Flag14-Sem)
-- This flag is set in an N_Compilation_Unit node if the Suppress_All
-- pragma appears anywhere in the unit. This accommodates the rather
@ -1168,12 +1158,6 @@ package Sinfo is
-- Suppress (All_Checks) appearing at the start of the configuration
-- pragmas for the unit.
-- Has_Pragma_Priority (Flag6-Sem)
-- A flag present in N_Subprogram_Body, N_Task_Definition and
-- N_Protected_Definition nodes to flag the presence of either a Priority
-- or Interrupt_Priority pragma in the declaration sequence (public or
-- private in the task and protected cases)
-- Has_Private_View (Flag11-Sem)
-- A flag present in generic nodes that have an entity, to indicate that
-- the node has a private type. Used to exchange private and full
@ -1194,14 +1178,6 @@ package Sinfo is
-- A flag present in an N_Task_Definition node to flag the presence of a
-- Storage_Size pragma.
-- Has_Task_Info_Pragma (Flag7-Sem)
-- A flag present in an N_Task_Definition node to flag the presence of a
-- Task_Info pragma. Used to detect duplicate pragmas.
-- Has_Task_Name_Pragma (Flag8-Sem)
-- A flag present in N_Task_Definition nodes to flag the presence of a
-- Task_Name pragma in the declaration sequence for the task.
-- Has_Wide_Character (Flag11-Sem)
-- Present in string literals, set if any wide character (i.e. character
-- code outside the Character range but within Wide_Character range)
@ -4619,13 +4595,11 @@ package Sinfo is
-- Acts_As_Spec (Flag4-Sem)
-- Bad_Is_Detected (Flag15) used only by parser
-- Do_Storage_Check (Flag17-Sem)
-- Has_Pragma_Priority (Flag6-Sem)
-- Is_Protected_Subprogram_Body (Flag7-Sem)
-- Is_Entry_Barrier_Function (Flag8-Sem)
-- Is_Task_Master (Flag5-Sem)
-- Was_Originally_Stub (Flag13-Sem)
-- Has_Relative_Deadline_Pragma (Flag9-Sem)
-- Has_Pragma_CPU (Flag14-Sem)
-------------------------
-- Expression Function --
@ -5109,13 +5083,8 @@ package Sinfo is
-- Visible_Declarations (List2)
-- Private_Declarations (List3) (set to No_List if no private part)
-- End_Label (Node4)
-- Has_Pragma_Priority (Flag6-Sem)
-- Has_Storage_Size_Pragma (Flag5-Sem)
-- Has_Task_Info_Pragma (Flag7-Sem)
-- Has_Task_Name_Pragma (Flag8-Sem)
-- Has_Relative_Deadline_Pragma (Flag9-Sem)
-- Has_Pragma_CPU (Flag14-Sem)
-- Has_Pragma_Dispatching_Domain (Flag15-Sem)
--------------------
-- 9.1 Task Item --
@ -5200,7 +5169,6 @@ package Sinfo is
-- Visible_Declarations (List2)
-- Private_Declarations (List3) (set to No_List if no private part)
-- End_Label (Node4)
-- Has_Pragma_Priority (Flag6-Sem)
------------------------------------------
-- 9.4 Protected Operation Declaration --
@ -8566,15 +8534,6 @@ package Sinfo is
function Has_No_Elaboration_Code
(N : Node_Id) return Boolean; -- Flag17
function Has_Pragma_CPU
(N : Node_Id) return Boolean; -- Flag14
function Has_Pragma_Dispatching_Domain
(N : Node_Id) return Boolean; -- Flag15
function Has_Pragma_Priority
(N : Node_Id) return Boolean; -- Flag6
function Has_Pragma_Suppress_All
(N : Node_Id) return Boolean; -- Flag14
@ -8590,12 +8549,6 @@ package Sinfo is
function Has_Storage_Size_Pragma
(N : Node_Id) return Boolean; -- Flag5
function Has_Task_Info_Pragma
(N : Node_Id) return Boolean; -- Flag7
function Has_Task_Name_Pragma
(N : Node_Id) return Boolean; -- Flag8
function Has_Wide_Character
(N : Node_Id) return Boolean; -- Flag11
@ -9556,15 +9509,6 @@ package Sinfo is
procedure Set_Has_No_Elaboration_Code
(N : Node_Id; Val : Boolean := True); -- Flag17
procedure Set_Has_Pragma_CPU
(N : Node_Id; Val : Boolean := True); -- Flag14
procedure Set_Has_Pragma_Dispatching_Domain
(N : Node_Id; Val : Boolean := True); -- Flag15
procedure Set_Has_Pragma_Priority
(N : Node_Id; Val : Boolean := True); -- Flag6
procedure Set_Has_Pragma_Suppress_All
(N : Node_Id; Val : Boolean := True); -- Flag14
@ -9580,12 +9524,6 @@ package Sinfo is
procedure Set_Has_Storage_Size_Pragma
(N : Node_Id; Val : Boolean := True); -- Flag5
procedure Set_Has_Task_Info_Pragma
(N : Node_Id; Val : Boolean := True); -- Flag7
procedure Set_Has_Task_Name_Pragma
(N : Node_Id; Val : Boolean := True); -- Flag8
procedure Set_Has_Wide_Character
(N : Node_Id; Val : Boolean := True); -- Flag11
@ -11990,15 +11928,10 @@ package Sinfo is
pragma Inline (Has_Local_Raise);
pragma Inline (Has_Self_Reference);
pragma Inline (Has_No_Elaboration_Code);
pragma Inline (Has_Pragma_CPU);
pragma Inline (Has_Pragma_Dispatching_Domain);
pragma Inline (Has_Pragma_Priority);
pragma Inline (Has_Pragma_Suppress_All);
pragma Inline (Has_Private_View);
pragma Inline (Has_Relative_Deadline_Pragma);
pragma Inline (Has_Storage_Size_Pragma);
pragma Inline (Has_Task_Info_Pragma);
pragma Inline (Has_Task_Name_Pragma);
pragma Inline (Has_Wide_Character);
pragma Inline (Has_Wide_Wide_Character);
pragma Inline (Header_Size_Added);
@ -12316,15 +12249,10 @@ package Sinfo is
pragma Inline (Set_Has_Local_Raise);
pragma Inline (Set_Has_Dynamic_Range_Check);
pragma Inline (Set_Has_No_Elaboration_Code);
pragma Inline (Set_Has_Pragma_CPU);
pragma Inline (Set_Has_Pragma_Dispatching_Domain);
pragma Inline (Set_Has_Pragma_Priority);
pragma Inline (Set_Has_Pragma_Suppress_All);
pragma Inline (Set_Has_Private_View);
pragma Inline (Set_Has_Relative_Deadline_Pragma);
pragma Inline (Set_Has_Storage_Size_Pragma);
pragma Inline (Set_Has_Task_Info_Pragma);
pragma Inline (Set_Has_Task_Name_Pragma);
pragma Inline (Set_Has_Wide_Character);
pragma Inline (Set_Has_Wide_Wide_Character);
pragma Inline (Set_Header_Size_Added);

9
gcc/ada/snames.adb-tmpl
View File

@ -209,10 +209,16 @@ package body Snames is
begin
if N = Name_AST_Entry then
return Pragma_AST_Entry;
elsif N = Name_CPU then
return Pragma_CPU;
elsif N = Name_Dispatching_Domain then
return Pragma_Dispatching_Domain;
elsif N = Name_Fast_Math then
return Pragma_Fast_Math;
elsif N = Name_Interface then
return Pragma_Interface;
elsif N = Name_Interrupt_Priority then
return Pragma_Interrupt_Priority;
elsif N = Name_Priority then
return Pragma_Priority;
elsif N = Name_Relative_Deadline then
@ -410,8 +416,11 @@ package body Snames is
begin
return N in First_Pragma_Name .. Last_Pragma_Name
or else N = Name_AST_Entry
or else N = Name_CPU
or else N = Name_Dispatching_Domain
or else N = Name_Fast_Math
or else N = Name_Interface
or else N = Name_Interrupt_Priority
or else N = Name_Relative_Deadline
or else N = Name_Priority
or else N = Name_Storage_Size

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

@ -374,7 +374,13 @@ package Snames is
Name_Default_Storage_Pool : constant Name_Id := N + $; -- Ada 12
Name_Disable_Atomic_Synchronization : constant Name_Id := N + $; -- GNAT
Name_Discard_Names : constant Name_Id := N + $;
Name_Dispatching_Domain : constant Name_Id := N + $; -- Ada 12
-- Note: Dispatching_Domain is not in this list because its name matches
-- the name of the corresponding attribute. However, it is included in the
-- definition of the type Pragma_Id, and the functions Get_Pragma_Id and
-- Is_Pragma_Id correctly recognize and process Dispatching_Domain.
-- Dispatching_Domain is a standard Ada 2012 pragma.
Name_Elaboration_Checks : constant Name_Id := N + $; -- GNAT
Name_Eliminate : constant Name_Id := N + $; -- GNAT
Name_Enable_Atomic_Synchronization : constant Name_Id := N + $; -- GNAT
@ -456,7 +462,13 @@ package Snames is
Name_CPP_Constructor : constant Name_Id := N + $; -- GNAT
Name_CPP_Virtual : constant Name_Id := N + $; -- GNAT
Name_CPP_Vtable : constant Name_Id := N + $; -- GNAT
Name_CPU : constant Name_Id := N + $; -- Ada 12
-- Note: CPU is not in this list because its name matches the name of
-- the corresponding attribute. However, it is included in the definition
-- of the type Pragma_Id, and the functions Get_Pragma_Id and Is_Pragma_Id
-- correctly recognize and process CPU. CPU is a standard Ada 2012
-- pragma.
Name_Debug : constant Name_Id := N + $; -- GNAT
Name_Elaborate : constant Name_Id := N + $; -- Ada 83
Name_Elaborate_All : constant Name_Id := N + $;
@ -489,11 +501,16 @@ package Snames is
-- Note: Interface is not in this list because its name matches an Ada 05
-- keyword. However it is included in the definition of the type
-- Attribute_Id, and the functions Get_Pragma_Id and Is_Pragma_Id correctly
-- recognize and process Name_Storage_Size.
-- recognize and process Name_Interface.
Name_Interface_Name : constant Name_Id := N + $; -- GNAT
Name_Interrupt_Handler : constant Name_Id := N + $;
Name_Interrupt_Priority : constant Name_Id := N + $;
-- Note: Interrupt_Priority is not in this list because its name matches
-- the name of the corresponding attribute. However, it is included in the
-- definition of the type Pragma_Id, and the functions Get_Pragma_Id and
-- Is_Pragma_Id correctly recognize and process Interrupt_Priority.
Name_Invariant : constant Name_Id := N + $; -- GNAT
Name_Java_Constructor : constant Name_Id := N + $; -- GNAT
Name_Java_Interface : constant Name_Id := N + $; -- GNAT
@ -754,6 +771,7 @@ package Snames is
Name_Constant_Indexing : constant Name_Id := N + $; -- GNAT
Name_Constrained : constant Name_Id := N + $;
Name_Count : constant Name_Id := N + $;
Name_CPU : constant Name_Id := N + $; -- Ada 12
Name_Default_Bit_Order : constant Name_Id := N + $; -- GNAT
Name_Default_Iterator : constant Name_Id := N + $; -- GNAT
Name_Definite : constant Name_Id := N + $;
@ -761,6 +779,7 @@ package Snames is
Name_Denorm : constant Name_Id := N + $;
Name_Descriptor_Size : constant Name_Id := N + $;
Name_Digits : constant Name_Id := N + $;
Name_Dispatching_Domain : constant Name_Id := N + $; -- Ada 12
Name_Elaborated : constant Name_Id := N + $; -- GNAT
Name_Emax : constant Name_Id := N + $; -- Ada 83
Name_Enabled : constant Name_Id := N + $; -- GNAT
@ -782,6 +801,7 @@ package Snames is
Name_Img : constant Name_Id := N + $; -- GNAT
Name_Implicit_Dereference : constant Name_Id := N + $; -- GNAT
Name_Integer_Value : constant Name_Id := N + $; -- GNAT
Name_Interrupt_Priority : constant Name_Id := N + $; -- Ada 12
Name_Invalid_Value : constant Name_Id := N + $; -- GNAT
Name_Iterator_Element : constant Name_Id := N + $; -- GNAT
Name_Large : constant Name_Id := N + $; -- Ada 83
@ -1329,6 +1349,7 @@ package Snames is
Attribute_Constant_Indexing,
Attribute_Constrained,
Attribute_Count,
Attribute_CPU,
Attribute_Default_Bit_Order,
Attribute_Default_Iterator,
Attribute_Definite,
@ -1336,6 +1357,7 @@ package Snames is
Attribute_Denorm,
Attribute_Descriptor_Size,
Attribute_Digits,
Attribute_Dispatching_Domain,
Attribute_Elaborated,
Attribute_Emax,
Attribute_Enabled,
@ -1357,6 +1379,7 @@ package Snames is
Attribute_Img,
Attribute_Implicit_Dereference,
Attribute_Integer_Value,
Attribute_Interrupt_Priority,
Attribute_Invalid_Value,
Attribute_Iterator_Element,
Attribute_Large,
@ -1576,7 +1599,6 @@ package Snames is
Pragma_Default_Storage_Pool,
Pragma_Disable_Atomic_Synchronization,
Pragma_Discard_Names,
Pragma_Dispatching_Domain,
Pragma_Elaboration_Checks,
Pragma_Eliminate,
Pragma_Enable_Atomic_Synchronization,
@ -1644,7 +1666,6 @@ package Snames is
Pragma_CPP_Constructor,
Pragma_CPP_Virtual,
Pragma_CPP_Vtable,
Pragma_CPU,
Pragma_Debug,
Pragma_Elaborate,
Pragma_Elaborate_All,
@ -1675,7 +1696,6 @@ package Snames is
Pragma_Inspection_Point,
Pragma_Interface_Name,
Pragma_Interrupt_Handler,
Pragma_Interrupt_Priority,
Pragma_Invariant,
Pragma_Java_Constructor,
Pragma_Java_Interface,
@ -1749,8 +1769,11 @@ package Snames is
-- match existing attribute names.
Pragma_AST_Entry,
Pragma_CPU,
Pragma_Dispatching_Domain,
Pragma_Fast_Math,
Pragma_Interface,
Pragma_Interrupt_Priority,
Pragma_Priority,
Pragma_Storage_Size,
Pragma_Storage_Unit,
@ -1829,8 +1852,9 @@ package Snames is
function Is_Pragma_Name (N : Name_Id) return Boolean;
-- Test to see if the name N is the name of a recognized pragma. Note that
-- pragmas AST_Entry, Fast_Math, Priority, Storage_Size, and Storage_Unit
-- are recognized as pragmas by this function even though their names are
-- pragmas AST_Entry, CPU, Dispatching_Domain, Fast_Math,
-- Interrupt_Priority, Priority, Storage_Size, and Storage_Unit are
-- recognized as pragmas by this function even though their names are
-- separate from the other pragma names. For this reason, clients should
-- always use this function, rather than do range tests on Name_Id values.
@ -1870,9 +1894,9 @@ package Snames is
-- Returns Id of pragma corresponding to given name. Returns Unknown_Pragma
-- if N is not a name of a known (Ada defined or GNAT-specific) pragma.
-- Note that the function also works correctly for names of pragmas that
-- are not included in the main list of pragma Names (AST_Entry, Priority,
-- Storage_Size, and Storage_Unit (e.g. Name_Storage_Size returns
-- Pragma_Storage_Size).
-- are not included in the main list of pragma Names (AST_Entry, CPU,
-- Dispatching_Domain, Interrupt_Priority, Priority, Storage_Size, and
-- Storage_Unit (e.g. Name_Storage_Size returns Pragma_Storage_Size).
function Get_Queuing_Policy_Id (N : Name_Id) return Queuing_Policy_Id;
-- Returns Id of queuing policy corresponding to given name. It is an error

3
gcc/ada/switch-c.adb
View File

@ -736,7 +736,8 @@ package body Switch.C is
if Ptr <= Max then
C := Switch_Chars (Ptr);
if C = '1' or C = '2' then
if C in '1' .. '2' then
Ptr := Ptr + 1;
Inline_Level := Character'Pos (C) - Character'Pos ('0');
end if;