diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2012-06-12 13:01:22 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2012-06-12 13:01:22 +0000 |
| commit | 89f1e35cf8eb00ada49f5c399fe1cad620fc49cc (patch) | |
| tree | 22d91ebb6c39908a565632e272740326a52d5cff /gcc/ada | |
| parent | a5e7b481248d9afbadc139a45bddd2c04f861163 (diff) | |
| download | gcc-89f1e35cf8eb00ada49f5c399fe1cad620fc49cc.tar.gz | |
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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@188455 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/ChangeLog | 95 | ||||
| -rw-r--r-- | gcc/ada/a-exexpr-gcc.adb | 11 | ||||
| -rw-r--r-- | gcc/ada/checks.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/einfo.adb | 169 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 66 | ||||
| -rw-r--r-- | gcc/ada/exp_attr.adb | 16 | ||||
| -rw-r--r-- | gcc/ada/exp_ch13.adb | 30 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 93 | ||||
| -rw-r--r-- | gcc/ada/exp_ch9.adb | 365 | ||||
| -rw-r--r-- | gcc/ada/freeze.adb | 55 | ||||
| -rw-r--r-- | gcc/ada/sem_attr.adb | 24 | ||||
| -rw-r--r-- | gcc/ada/sem_aux.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 1507 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.ads | 8 | ||||
| -rw-r--r-- | gcc/ada/sem_ch9.adb | 91 | ||||
| -rw-r--r-- | gcc/ada/sem_ch9.ads | 19 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 165 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 31 | ||||
| -rw-r--r-- | gcc/ada/sinfo.adb | 86 | ||||
| -rw-r--r-- | gcc/ada/sinfo.ads | 72 | ||||
| -rw-r--r-- | gcc/ada/snames.adb-tmpl | 9 | ||||
| -rw-r--r-- | gcc/ada/snames.ads-tmpl | 48 | ||||
| -rw-r--r-- | gcc/ada/switch-c.adb | 3 |
23 files changed, 1717 insertions, 1269 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index cadead57b75..7f654d0158b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -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'. diff --git a/gcc/ada/a-exexpr-gcc.adb b/gcc/ada/a-exexpr-gcc.adb index f43c345dca5..2f2e7a76cba 100644 --- a/gcc/ada/a-exexpr-gcc.adb +++ b/gcc/ada/a-exexpr-gcc.adb @@ -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; @@ -481,9 +482,9 @@ package body Exception_Propagation is GCC_Exception := new GNAT_GCC_Exception' - (Header => (Class => GNAT_Exception_Class, + (Header => (Class => GNAT_Exception_Class, Cleanup => GNAT_GCC_Exception_Cleanup'Address, - others => 0), + others => 0), Occurrence => Excep.all); -- Propagate it diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index ab628b30f8b..195b69e1be8 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -7378,12 +7378,10 @@ 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 - return Is_Check_Suppressed (E, Tag_Check); - end if; + if Present (E) + and then Checks_May_Be_Suppressed (E) + then + return Is_Check_Suppressed (E, Tag_Check); end if; return Scope_Suppress (Tag_Check); diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index b7ffe58fd59..9c4d22bd72d 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -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)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index c69857a8bdd..49a1cf61cb9 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -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); diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 2bfe692c4fc..d63d4dee1ea 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -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 -- diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index 038a8442b61..26eaec28b4e 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -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. - -- task_typeZ := expression + -- 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, - Make_Assignment_Statement (Loc, - Name => New_Reference_To (Storage_Size_Variable (Ent), Loc), - Expression => - Convert_To (RTE (RE_Size_Type), Expression (N)))); + declare + Assign : Node_Id; + + begin + Assign := + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Storage_Size_Variable (Ent), Loc), + Expression => + 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 diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 8240ed4d9a2..fa64f9a0b0b 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -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) diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index e0ea3219cff..2a533c93c3e 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -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,51 +11566,19 @@ package body Exp_Ch9 is Collect_Entry_Families (Loc, Cdecls, Size_Decl, Tasktyp); - -- Add the _Priority component if a Priority pragma is present + -- Add the _Priority component with no expression - 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; - - 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)), - Expression => Expr)); - end; - end if; + 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)))); - -- 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,30 +11619,21 @@ 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 - - if Present (Taskdef) and then Has_Pragma_CPU (Taskdef) then - Append_To (Cdecls, - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uCPU), + -- Add the _CPU component with no expression - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Reference_To (RTE (RE_CPU_Range), Loc)), + Append_To (Cdecls, + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uCPU), - Expression => New_Copy ( - Expression (First ( - Pragma_Argument_Associations ( - Find_Task_Or_Protected_Pragma - (Taskdef, Name_CPU))))))); - end if; + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + 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 - (Pragma_Argument_Associations - (Find_Task_Or_Protected_Pragma - (Tdef, Name_Task_Name)))))); + (Expression + (First + (Pragma_Argument_Associations + (Get_Rep_Pragma_For_Entity (Ttyp, Name_Task_Name)))))); else Append_To (Args, Make_Identifier (Loc, Name_uTask_Name)); diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 0f20edf60f8..558022e7582 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -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 diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 345fdb55eeb..bf700803086 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -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 -- diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 4f93f22ab36..6499249d6d6 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -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 diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 80781ab7bd7..d1318fef127 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -46,6 +46,7 @@ with Sem_Aux; use Sem_Aux; with Sem_Ch3; use Sem_Ch3; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; +with Sem_Ch9; use Sem_Ch9; with Sem_Dim; use Sem_Dim; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; @@ -693,26 +694,27 @@ package body Sem_Ch13 is L : constant List_Id := Aspect_Specifications (N); Ins_Node : Node_Id := N; - -- Insert pragmas (except Pre/Post/Invariant/Predicate) after this node + -- Insert pragmas/attribute definition clause after this node when no + -- delayed analysis is required. -- The general processing involves building an attribute definition - -- clause or a pragma node that corresponds to the aspect. Then one - -- of two things happens: - - -- If we are required to delay the evaluation of this aspect to the - -- freeze point, we attach the corresponding pragma/attribute definition - -- clause to the aspect specification node, which is then placed in the - -- Rep Item chain. In this case we mark the entity by setting the flag - -- Has_Delayed_Aspects and we evaluate the rep item at the freeze point. - - -- If no delay is required, we just insert the pragma or attribute - -- after the declaration, and it will get processed by the normal - -- circuit. The From_Aspect_Specification flag is set on the pragma - -- or attribute definition node in either case to activate special - -- processing (e.g. not traversing the list of homonyms for inline). - - Delay_Required : Boolean := False; - -- Set True if delay is required + -- clause or a pragma node that corresponds to the aspect. Then in order + -- to delay the evaluation of this aspect to the freeze point, we attach + -- the corresponding pragma/attribute definition clause to the aspect + -- specification node, which is then placed in the Rep Item chain. In + -- this case we mark the entity by setting the flag Has_Delayed_Aspects + -- and we evaluate the rep item at the freeze point. When the aspect + -- doesn't have a corresponding pragma/attribute definition clause, then + -- its analysis is simply delayed at the freeze point. + + -- Some special cases don't require delay analysis, thus the aspect is + -- analyzed right now. + + -- Note that there is a special handling for + -- Pre/Post/Test_Case/Contract_Case aspects. In this case, we do not + -- have to worry about delay issues, since the pragmas themselves deal + -- with delay of visibility for the expression analysis. Thus, we just + -- insert the pragma after the node N. begin pragma Assert (Present (L)); @@ -722,82 +724,98 @@ package body Sem_Ch13 is Aspect := First (L); Aspect_Loop : while Present (Aspect) loop declare - Loc : constant Source_Ptr := Sloc (Aspect); - Id : constant Node_Id := Identifier (Aspect); Expr : constant Node_Id := Expression (Aspect); + Id : constant Node_Id := Identifier (Aspect); + Loc : constant Source_Ptr := Sloc (Aspect); Nam : constant Name_Id := Chars (Id); A_Id : constant Aspect_Id := Get_Aspect_Id (Nam); Anod : Node_Id; + Delay_Required : Boolean := True; + -- Set False if delay is not required + Eloc : Source_Ptr := No_Location; -- Source location of expression, modified when we split PPC's. It -- is set below when Expr is present. - 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; + procedure Analyze_Aspect_External_Or_Link_Name; + -- This routine performs the analysis of the External_Name or + -- Link_Name aspects. - ----------------------------------------- - -- Check_False_Aspect_For_Derived_Type -- - ----------------------------------------- + procedure Analyze_Aspect_Implicit_Dereference; + -- This routine performs the analysis of the Implicit_Dereference + -- aspects. + + ------------------------------------------ + -- Analyze_Aspect_External_Or_Link_Name -- + ------------------------------------------ - procedure Check_False_Aspect_For_Derived_Type is + procedure Analyze_Aspect_External_Or_Link_Name is begin - -- We are only checking derived types + -- Verify that there is an Import/Export aspect defined for the + -- entity. The processing of that aspect in turn checks that + -- there is a Convention aspect declared. The pragma is + -- constructed when processing the Convention aspect. - if not Is_Derived_Type (E) then - return; - end if; + declare + A : Node_Id; - case A_Id is - when Aspect_Atomic | Aspect_Shared => - if not Is_Atomic (E) then - return; - end if; + begin + A := First (L); - when Aspect_Atomic_Components => - if not Has_Atomic_Components (E) then - return; - end if; + while Present (A) loop + exit when Chars (Identifier (A)) = Name_Export + or else Chars (Identifier (A)) = Name_Import; + Next (A); + end loop; - when Aspect_Discard_Names => - if not Discard_Names (E) then - return; - end if; + if No (A) then + Error_Msg_N + ("Missing Import/Export for Link/External name", + Aspect); + end if; + end; + end Analyze_Aspect_External_Or_Link_Name; - when Aspect_Pack => - if not Is_Packed (E) then - return; - end if; + ----------------------------------------- + -- Analyze_Aspect_Implicit_Dereference -- + ----------------------------------------- - when Aspect_Unchecked_Union => - if not Is_Unchecked_Union (E) then - return; - end if; + procedure Analyze_Aspect_Implicit_Dereference is + begin + if not Is_Type (E) + or else not Has_Discriminants (E) + then + Error_Msg_N + ("Aspect must apply to a type with discriminants", N); - when Aspect_Volatile => - if not Is_Volatile (E) then - return; - end if; + else + declare + Disc : Entity_Id; - when Aspect_Volatile_Components => - if not Has_Volatile_Components (E) then - return; - end if; + begin + Disc := First_Discriminant (E); - when others => - return; - end case; + while Present (Disc) loop + if Chars (Expr) = Chars (Disc) + and then Ekind (Etype (Disc)) = + E_Anonymous_Access_Type + then + Set_Has_Implicit_Dereference (E); + Set_Has_Implicit_Dereference (Disc); + return; + end if; - -- Fall through means we are canceling an inherited aspect + Next_Discriminant (Disc); + end loop; - Error_Msg_Name_1 := Nam; - Error_Msg_NE - ("derived type& inherits aspect%, cannot cancel", Expr, E); - end Check_False_Aspect_For_Derived_Type; + -- Error if no proper access discriminant. - -- Start of processing for Aspect_Loop + Error_Msg_NE + ("not an access discriminant of&", Expr, E); + end; + end if; + end Analyze_Aspect_Implicit_Dereference; begin -- Skip aspect if already analyzed (not clear if this is needed) @@ -926,199 +944,25 @@ package body Sem_Ch13 is when No_Aspect => raise Program_Error; - -- Aspects taking an optional boolean argument - - when Boolean_Aspects => - Set_Is_Boolean_Aspect (Aspect); - - -- Special treatment for Aspect_Lock_Free since it is the - -- only Boolean_Aspect that doesn't correspond to a pragma. - - if A_Id = Aspect_Lock_Free then - if Ekind (E) /= E_Protected_Type then - Error_Msg_N - ("aspect % only applies to protected objects", - Aspect); - end if; - - -- Set the Uses_Lock_Free flag to True if there is no - -- expression or if the expression is True. - - if No (Expr) or else Is_True (Static_Boolean (Expr)) then - Set_Uses_Lock_Free (E); - end if; - - goto Continue; - - -- For Import/Export, Verify that there is an aspect - -- Convention that will incorporate the Import/Export - -- aspect, and eventual Link/External names. - - elsif A_Id = Aspect_Import or else A_Id = Aspect_Export then - declare - A : Node_Id; - - begin - A := First (L); - while Present (A) loop - exit when Chars (Identifier (A)) = Name_Convention; - Next (A); - end loop; - - if No (A) then - Error_Msg_N - ("missing Convention aspect for Export/Import", - Aspect); - end if; - end; - - goto Continue; - end if; - - -- For all other aspects we just create a matching pragma - -- and insert it, if the expression is missing or set to - -- True. If the expression is False, we can ignore the - -- aspect with the exception that in the case of a derived - -- type, we must check for an illegal attempt to cancel an - -- inherited aspect. - - if Present (Expr) - and then Is_False (Static_Boolean (Expr)) - then - Check_False_Aspect_For_Derived_Type; - goto Continue; - end if; - - -- If True, build corresponding pragma node - - Aitem := - Make_Pragma (Loc, - Pragma_Argument_Associations => New_List (Ent), - Pragma_Identifier => - Make_Identifier (Sloc (Id), Chars (Id))); - - -- Never need to delay for boolean aspects - - pragma Assert (not Delay_Required); - - -- Library unit aspects. These are boolean aspects, but we - -- have to do special things with the insertion, since the - -- pragma belongs inside the declarations of a package. - - when Library_Unit_Aspects => - if Present (Expr) - and then Is_False (Static_Boolean (Expr)) - then - goto Continue; - end if; - - -- Build corresponding pragma node - - Aitem := - Make_Pragma (Loc, - Pragma_Argument_Associations => New_List (Ent), - Pragma_Identifier => - Make_Identifier (Sloc (Id), Chars (Id))); - - -- This requires special handling in the case of a package - -- declaration, the pragma needs to be inserted in the list - -- of declarations for the associated package. There is no - -- issue of visibility delay for these aspects. - - if Nkind (N) = N_Package_Declaration then - if Nkind (Parent (N)) /= N_Compilation_Unit then - Error_Msg_N - ("incorrect context for library unit aspect&", Id); - else - Prepend - (Aitem, Visible_Declarations (Specification (N))); - end if; - - goto Continue; - end if; - - -- If not package declaration, no delay is required - - pragma Assert (not Delay_Required); - - -- Aspects related to container iterators. These aspects denote - -- subprograms, and thus must be delayed. - - when Aspect_Constant_Indexing | - Aspect_Variable_Indexing => - - if not Is_Type (E) or else not Is_Tagged_Type (E) then - Error_Msg_N ("indexing applies to a tagged type", N); - end if; - - Aitem := - Make_Attribute_Definition_Clause (Loc, - Name => Ent, - Chars => Chars (Id), - Expression => Relocate_Node (Expr)); - - Delay_Required := True; - Set_Is_Delayed_Aspect (Aspect); - - when Aspect_Default_Iterator | - Aspect_Iterator_Element => - - Aitem := - Make_Attribute_Definition_Clause (Loc, - Name => Ent, - Chars => Chars (Id), - Expression => Relocate_Node (Expr)); - - Delay_Required := True; - Set_Is_Delayed_Aspect (Aspect); - - when Aspect_Implicit_Dereference => - if not Is_Type (E) - or else not Has_Discriminants (E) - then - Error_Msg_N - ("Aspect must apply to a type with discriminants", N); - goto Continue; - - else - declare - Disc : Entity_Id; - - begin - Disc := First_Discriminant (E); - while Present (Disc) loop - if Chars (Expr) = Chars (Disc) - and then Ekind (Etype (Disc)) = - E_Anonymous_Access_Type - then - Set_Has_Implicit_Dereference (E); - Set_Has_Implicit_Dereference (Disc); - goto Continue; - end if; - - Next_Discriminant (Disc); - end loop; - - -- Error if no proper access discriminant. - - Error_Msg_NE - ("not an access discriminant of&", Expr, E); - end; - - goto Continue; - end if; - - -- Aspects corresponding to attribute definition clauses + -- Case 1: Aspects corresponding to attribute definition + -- clauses. when Aspect_Address | Aspect_Alignment | Aspect_Bit_Order | Aspect_Component_Size | + Aspect_Constant_Indexing | + Aspect_CPU | + Aspect_Default_Iterator | + Aspect_Dispatching_Domain | Aspect_External_Tag | Aspect_Input | + Aspect_Interrupt_Priority | + Aspect_Iterator_Element | Aspect_Machine_Radix | Aspect_Object_Size | Aspect_Output | + Aspect_Priority | Aspect_Read | Aspect_Scalar_Storage_Order | Aspect_Size | @@ -1128,8 +972,20 @@ package body Sem_Ch13 is Aspect_Storage_Size | Aspect_Stream_Size | Aspect_Value_Size | + Aspect_Variable_Indexing | Aspect_Write => + -- Indexing aspects apply only to tagged type + + if (A_Id = Aspect_Constant_Indexing + or else A_Id = Aspect_Variable_Indexing) + and then not (Is_Type (E) + and then Is_Tagged_Type (E)) + then + Error_Msg_N ("indexing applies to a tagged type", N); + goto Continue; + end if; + -- Construct the attribute definition clause Aitem := @@ -1138,22 +994,12 @@ package body Sem_Ch13 is Chars => Chars (Id), Expression => Relocate_Node (Expr)); - -- A delay is required except in the common case where - -- the expression is a literal, in which case it is fine - -- to take care of it right away. - - if Nkind_In (Expr, N_Integer_Literal, N_String_Literal) then - pragma Assert (not Delay_Required); - null; - else - Delay_Required := True; - Set_Is_Delayed_Aspect (Aspect); - end if; + -- Case 2: Aspects cooresponding to pragmas - -- Aspects corresponding to pragmas with two arguments, where - -- the first argument is a local name referring to the entity, - -- and the second argument is the aspect definition expression - -- which is an expression that does not get analyzed. + -- Case 2a: Aspects corresponding to pragmas with two + -- arguments, where the first argument is a local name + -- referring to the entity, and the second argument is the + -- aspect definition expression. when Aspect_Suppress | Aspect_Unsuppress => @@ -1168,11 +1014,6 @@ package body Sem_Ch13 is Pragma_Identifier => Make_Identifier (Sloc (Id), Chars (Id))); - -- We don't have to play the delay game here, since the only - -- values are check names which don't get analyzed anyway. - - pragma Assert (not Delay_Required); - when Aspect_Synchronization => -- The aspect corresponds to pragma Implemented. @@ -1186,11 +1027,53 @@ package body Sem_Ch13 is Pragma_Identifier => Make_Identifier (Sloc (Id), Name_Implemented)); - pragma Assert (not Delay_Required); + -- No delay is required since the only values are: By_Entry + -- | By_Protected_Procedure | By_Any | Optional which don't + -- get analyzed anyway. - -- Aspects corresponding to pragmas with two arguments, where - -- the second argument is a local name referring to the entity, - -- and the first argument is the aspect definition expression. + Delay_Required := False; + + when Aspect_Attach_Handler => + Aitem := + Make_Pragma (Loc, + Pragma_Identifier => + Make_Identifier (Sloc (Id), Name_Attach_Handler), + Pragma_Argument_Associations => + New_List (Ent, Relocate_Node (Expr))); + + when Aspect_Dynamic_Predicate | + Aspect_Predicate | + Aspect_Static_Predicate => + + -- Construct the pragma (always a pragma Predicate, with + -- flags recording whether it is static/dynamic). + + Aitem := + Make_Pragma (Loc, + Pragma_Argument_Associations => + New_List (Ent, Relocate_Node (Expr)), + Class_Present => Class_Present (Aspect), + Pragma_Identifier => + Make_Identifier (Sloc (Id), Name_Predicate)); + + -- If the type is private, indicate that its completion + -- has a freeze node, because that is the one that will be + -- visible at freeze time. + + Set_Has_Predicates (E); + + if Is_Private_Type (E) + and then Present (Full_View (E)) + then + Set_Has_Predicates (Full_View (E)); + Set_Has_Delayed_Aspects (Full_View (E)); + Ensure_Freeze_Node (Full_View (E)); + end if; + + -- Case 2b: Aspects corresponding to pragmas with two + -- arguments, where the second argument is a local name + -- referring to the entity, and the first argument is the + -- aspect definition expression. when Aspect_Convention => @@ -1215,56 +1098,36 @@ package body Sem_Ch13 is L_Assoc := Empty; E_Assoc := Empty; - -- Loop to look for Import/Export/Link_Name/External_Name - A := First (L); while Present (A) loop A_Name := Chars (Identifier (A)); - -- Import/Export - if A_Name = Name_Import - or else - A_Name = Name_Export + or else A_Name = Name_Export then - -- Forbid duplicates, at most one can appear - if Found then - Error_Msg_Name_1 := A_Name; - Error_Msg_Name_2 := P_Name; - Error_Msg_N - ("% aspect conflicts with previous % aspect", - A); + Error_Msg_N ("conflicting", A); else Found := True; end if; - -- Record name of pragma to generate - P_Name := A_Name; - -- Capture Link_Name - elsif A_Name = Name_Link_Name then L_Assoc := Make_Pragma_Argument_Association (Loc, - Chars => A_Name, + Chars => A_Name, Expression => Relocate_Node (Expression (A))); - -- Capture External_Name - elsif A_Name = Name_External_Name then E_Assoc := Make_Pragma_Argument_Association (Loc, - Chars => A_Name, + Chars => A_Name, Expression => Relocate_Node (Expression (A))); end if; Next (A); end loop; - -- Construct pragma - Arg_List := New_List (Relocate_Node (Expr), Ent); - if Present (L_Assoc) then Append_To (Arg_List, L_Assoc); end if; @@ -1296,102 +1159,88 @@ package body Sem_Ch13 is -- We don't have to play the delay game here, since the only -- values are ON/OFF which don't get analyzed anyway. - pragma Assert (not Delay_Required); + Delay_Required := False; - -- Default_Value and Default_Component_Value aspects. These - -- are specially handled because they have no corresponding - -- pragmas or attributes. + -- Case 2c: Aspects corresponding to pragmas with three + -- arguments. - when Aspect_Default_Value | Aspect_Default_Component_Value => - Error_Msg_Name_1 := Chars (Id); + -- Invariant aspects have a first argument that references the + -- entity, a second argument that is the expression and a third + -- argument that is an appropriate message. - if not Is_Type (E) then - Error_Msg_N ("aspect% can only apply to a type", Id); - goto Continue; + when Aspect_Invariant | + Aspect_Type_Invariant => - elsif not Is_First_Subtype (E) then - Error_Msg_N ("aspect% cannot apply to subtype", Id); - goto Continue; + -- Analysis of the pragma will verify placement legality: + -- an invariant must apply to a private type, or appear in + -- the private part of a spec and apply to a completion. - elsif A_Id = Aspect_Default_Value - and then not Is_Scalar_Type (E) - then - Error_Msg_N - ("aspect% can only be applied to scalar type", Id); - goto Continue; + -- Construct the pragma - elsif A_Id = Aspect_Default_Component_Value then - if not Is_Array_Type (E) then - Error_Msg_N - ("aspect% can only be applied to array type", Id); - goto Continue; - elsif not Is_Scalar_Type (Component_Type (E)) then - Error_Msg_N - ("aspect% requires scalar components", Id); - goto Continue; - end if; + Aitem := + Make_Pragma (Loc, + Pragma_Argument_Associations => + New_List (Ent, Relocate_Node (Expr)), + Class_Present => Class_Present (Aspect), + Pragma_Identifier => + Make_Identifier (Sloc (Id), Name_Invariant)); + + -- Add message unless exception messages are suppressed + + if not Opt.Exception_Locations_Suppressed then + Append_To (Pragma_Argument_Associations (Aitem), + Make_Pragma_Argument_Association (Eloc, + Chars => Name_Message, + Expression => + Make_String_Literal (Eloc, + Strval => "failed invariant from " + & Build_Location_String (Eloc)))); end if; - Aitem := Empty; - Delay_Required := True; + -- For Invariant case, insert immediately after the entity + -- declaration. We do not have to worry about delay issues + -- since the pragma processing takes care of this. + Set_Is_Delayed_Aspect (Aspect); - Set_Has_Default_Aspect (Base_Type (Entity (Ent))); + Delay_Required := False; - if Is_Scalar_Type (E) then - Set_Default_Aspect_Value (Entity (Ent), Expr); - else - Set_Default_Aspect_Component_Value (Entity (Ent), Expr); - end if; + -- Case 3 : Aspects that don't correspond to pragma/attribute + -- definition clause. - when Aspect_Attach_Handler => - Aitem := - Make_Pragma (Loc, - Pragma_Identifier => - Make_Identifier (Sloc (Id), Name_Attach_Handler), - Pragma_Argument_Associations => - New_List (Ent, Relocate_Node (Expr))); + -- Case 3a: The aspects listed below don't correspond to + -- pragmas/attributes but do require delayed analysis. - Set_From_Aspect_Specification (Aitem, True); - Set_Corresponding_Aspect (Aitem, Aspect); + when Aspect_Default_Value | + Aspect_Default_Component_Value => + Aitem := Empty; - pragma Assert (not Delay_Required); + -- Case 3b: The aspects listed below don't correspond to + -- pragmas/attributes and don't need delayed analysis. - when Aspect_Priority | - Aspect_Interrupt_Priority | - Aspect_Dispatching_Domain | - Aspect_CPU => - declare - Pname : Name_Id; + -- For Implicit_Dereference, External_Name and Link_Name, only + -- the legality checks are done during the analysis, thus no + -- delay is required. - begin - if A_Id = Aspect_Priority then - Pname := Name_Priority; + when Aspect_Implicit_Dereference => + Analyze_Aspect_Implicit_Dereference; + goto Continue; - elsif A_Id = Aspect_Interrupt_Priority then - Pname := Name_Interrupt_Priority; + when Aspect_External_Name | + Aspect_Link_Name => + Analyze_Aspect_External_Or_Link_Name; + goto Continue; - elsif A_Id = Aspect_CPU then - Pname := Name_CPU; + when Aspect_Dimension => + Analyze_Aspect_Dimension (N, Id, Expr); + goto Continue; - else - Pname := Name_Dispatching_Domain; - end if; + when Aspect_Dimension_System => + Analyze_Aspect_Dimension_System (N, Id, Expr); + goto Continue; - Aitem := - Make_Pragma (Loc, - Pragma_Identifier => - Make_Identifier (Sloc (Id), Pname), - Pragma_Argument_Associations => - New_List - (Make_Pragma_Argument_Association - (Sloc => Sloc (Id), - Expression => Relocate_Node (Expr)))); - - Set_From_Aspect_Specification (Aitem, True); - Set_Corresponding_Aspect (Aitem, Aspect); - - pragma Assert (not Delay_Required); - end; + -- Case 4: Special handling for aspects + -- Pre/Post/Test_Case/Contract_Case whose corresponding pragmas + -- take care of the delay. -- Aspects Pre/Post generate Precondition/Postcondition pragmas -- with a first argument that is the expression, and a second @@ -1493,97 +1342,6 @@ package body Sem_Ch13 is goto Continue; end; - -- Invariant aspects generate a corresponding pragma with a - -- first argument that is the entity, a second argument that is - -- the expression and a third argument that is an appropriate - -- message. This is inserted right after the declaration, to - -- get the required pragma placement. The pragma processing - -- takes care of the required delay. - - when Aspect_Invariant | - Aspect_Type_Invariant => - - -- Analysis of the pragma will verify placement legality: - -- an invariant must apply to a private type, or appear in - -- the private part of a spec and apply to a completion. - - -- Construct the pragma - - Aitem := - Make_Pragma (Loc, - Pragma_Argument_Associations => - New_List (Ent, Relocate_Node (Expr)), - Class_Present => Class_Present (Aspect), - Pragma_Identifier => - Make_Identifier (Sloc (Id), Name_Invariant)); - - -- Add message unless exception messages are suppressed - - if not Opt.Exception_Locations_Suppressed then - Append_To (Pragma_Argument_Associations (Aitem), - Make_Pragma_Argument_Association (Eloc, - Chars => Name_Message, - Expression => - Make_String_Literal (Eloc, - Strval => "failed invariant from " - & Build_Location_String (Eloc)))); - end if; - - Set_From_Aspect_Specification (Aitem, True); - Set_Corresponding_Aspect (Aitem, Aspect); - Set_Is_Delayed_Aspect (Aspect); - - -- For Invariant case, insert immediately after the entity - -- declaration. We do not have to worry about delay issues - -- since the pragma processing takes care of this. - - Insert_After (N, Aitem); - goto Continue; - - -- Predicate aspects generate a corresponding pragma with a - -- first argument that is the entity, and the second argument - -- is the expression. - - when Aspect_Dynamic_Predicate | - Aspect_Predicate | - Aspect_Static_Predicate => - - -- Construct the pragma (always a pragma Predicate, with - -- flags recording whether it is static/dynamic). - - Aitem := - Make_Pragma (Loc, - Pragma_Argument_Associations => - New_List (Ent, Relocate_Node (Expr)), - Class_Present => Class_Present (Aspect), - Pragma_Identifier => - Make_Identifier (Sloc (Id), Name_Predicate)); - - Set_From_Aspect_Specification (Aitem, True); - Set_Corresponding_Aspect (Aitem, Aspect); - - -- Make sure we have a freeze node (it might otherwise be - -- missing in cases like subtype X is Y, and we would not - -- have a place to build the predicate function). - - -- If the type is private, indicate that its completion - -- has a freeze node, because that is the one that will be - -- visible at freeze time. - - Set_Has_Predicates (E); - - if Is_Private_Type (E) - and then Present (Full_View (E)) - then - Set_Has_Predicates (Full_View (E)); - Set_Has_Delayed_Aspects (Full_View (E)); - Ensure_Freeze_Node (Full_View (E)); - end if; - - Ensure_Freeze_Node (E); - Set_Is_Delayed_Aspect (Aspect); - Delay_Required := True; - when Aspect_Contract_Case | Aspect_Test_Case => declare @@ -1655,188 +1413,195 @@ package body Sem_Ch13 is Pragma_Argument_Associations => Args); - Set_From_Aspect_Specification (Aitem, True); - Set_Corresponding_Aspect (Aitem, Aspect); - Set_Is_Delayed_Aspect (Aspect); - - -- Insert immediately after the entity declaration - - Insert_After (N, Aitem); - - goto Continue; + Delay_Required := False; end; - when Aspect_Dimension => - Analyze_Aspect_Dimension (N, Id, Expr); - goto Continue; + -- Case 5: Special handling for aspects with an optional + -- boolean argument. - when Aspect_Dimension_System => - Analyze_Aspect_Dimension_System (N, Id, Expr); - goto Continue; - - when Aspect_External_Name | - Aspect_Link_Name => + -- In the general case, the corresponding pragma cannot be + -- generated yet because the evaluation of the boolean needs to + -- be delayed til the freeze point. - -- Verify that there is an Import/Export aspect defined for - -- the entity. The processing of that aspect in turn checks - -- that there is a Convention aspect declared. The pragma is - -- constructed when processing the Convention aspect. + when Boolean_Aspects | + Library_Unit_Aspects => - declare - A : Node_Id; + Set_Is_Boolean_Aspect (Aspect); - begin - A := First (L); - while Present (A) loop - exit when Chars (Identifier (A)) = Name_Export - or else Chars (Identifier (A)) = Name_Import; - Next (A); - end loop; + -- Lock_Free aspect only apply to protected objects - if No (A) then + if A_Id = Aspect_Lock_Free then + if Ekind (E) /= E_Protected_Type then Error_Msg_N - ("Missing Import/Export for Link/External name", - Aspect); - end if; - end; + ("aspect % only applies to a protected object", + Aspect); - goto Continue; - end case; + else + -- Set the Uses_Lock_Free flag to True if there is no + -- expression or if the expression is True. ??? The + -- evaluation of this aspect should be delayed to the + -- freeze point. - -- If a delay is required, we delay the freeze (not much point in - -- delaying the aspect if we don't delay the freeze!). The pragma - -- or attribute clause if there is one is then attached to the - -- aspect specification which is placed in the rep item list. + if No (Expr) + or else Is_True (Static_Boolean (Expr)) + then + Set_Uses_Lock_Free (E); + end if; + end if; - if Delay_Required then - if Present (Aitem) then - Set_From_Aspect_Specification (Aitem, True); + goto Continue; - if Nkind (Aitem) = N_Pragma then - Set_Corresponding_Aspect (Aitem, Aspect); - end if; + elsif A_Id = Aspect_Import + or else A_Id = Aspect_Export + then - Set_Is_Delayed_Aspect (Aitem); - Set_Aspect_Rep_Item (Aspect, Aitem); - end if; + -- Verify that there is an aspect Convention that will + -- incorporate the Import/Export aspect, and eventual + -- Link/External names. - Ensure_Freeze_Node (E); - Set_Has_Delayed_Aspects (E); - Record_Rep_Item (E, Aspect); + declare + A : Node_Id; - -- If no delay required, insert the pragma/clause in the tree + begin + A := First (L); + while Present (A) loop + exit when Chars (Identifier (A)) = Name_Convention; + Next (A); + end loop; - else - Set_From_Aspect_Specification (Aitem, True); + if No (A) then + Error_Msg_N + ("missing Convention aspect for Export/Import", + Aspect); + end if; + end; - if Nkind (Aitem) = N_Pragma then - Set_Corresponding_Aspect (Aitem, Aspect); - end if; + goto Continue; + end if; - -- If this is a compilation unit, we will put the pragma in - -- the Pragmas_After list of the N_Compilation_Unit_Aux node. + -- This requires special handling in the case of a package + -- declaration, the pragma needs to be inserted in the list + -- of declarations for the associated package. There is no + -- issue of visibility delay for these aspects. - if Nkind (Parent (Ins_Node)) = N_Compilation_Unit then - declare - Aux : constant Node_Id := - Aux_Decls_Node (Parent (Ins_Node)); + if A_Id in Library_Unit_Aspects + and then Nkind (N) = N_Package_Declaration + and then Nkind (Parent (N)) /= N_Compilation_Unit + then + Error_Msg_N + ("incorrect context for library unit aspect&", Id); + goto Continue; + end if; - begin - pragma Assert (Nkind (Aux) = N_Compilation_Unit_Aux); + -- Special handling when the aspect has no expression. In + -- this case the value is considered to be True. Thus, we + -- simply insert the pragma, no delay is required. - if No (Pragmas_After (Aux)) then - Set_Pragmas_After (Aux, Empty_List); - end if; + if No (Expr) then + Aitem := + Make_Pragma (Loc, + Pragma_Argument_Associations => New_List (Ent), + Pragma_Identifier => + Make_Identifier (Sloc (Id), Chars (Id))); - -- For Pre_Post put at start of list, otherwise at end + Delay_Required := False; - if A_Id in Pre_Post_Aspects then - Prepend (Aitem, Pragmas_After (Aux)); - else - Append (Aitem, Pragmas_After (Aux)); - end if; - end; + -- In general cases, the corresponding pragma/attribute + -- definition clause will be inserted later at the freezing + -- point. - -- Here if not compilation unit case + else + Aitem := Empty; + end if; + end case; - else - case A_Id is + -- Attach the corresponding pragma/attribute definition clause to + -- the aspect specification node. - -- For Pre/Post cases, insert immediately after the - -- entity declaration, since that is the required pragma - -- placement. + if Present (Aitem) then + Set_From_Aspect_Specification (Aitem, True); - when Pre_Post_Aspects => - Insert_After (N, Aitem); + if Nkind (Aitem) = N_Pragma then + Set_Corresponding_Aspect (Aitem, Aspect); + end if; + end if; - -- For Priority aspects, insert into the task or - -- protected definition, which we need to create if it's - -- not there. The same applies to CPU and - -- Dispatching_Domain but only to tasks. + -- In the context of a compilation unit, we directly put the + -- pragma in the Pragmas_After list of the + -- N_Compilation_Unit_Aux node. No delay is required here. - when Aspect_Priority | - Aspect_Interrupt_Priority | - Aspect_Dispatching_Domain | - Aspect_CPU => - declare - T : Node_Id; -- the type declaration - L : List_Id; -- list of decls of task/protected + if Nkind (Parent (N)) = N_Compilation_Unit + and then (Present (Aitem) or else Is_Boolean_Aspect (Aspect)) + then + declare + Aux : constant Node_Id := Aux_Decls_Node (Parent (N)); - begin - if Nkind (N) = N_Object_Declaration then - T := Parent (Etype (Defining_Identifier (N))); - else - T := N; - end if; + begin + pragma Assert (Nkind (Aux) = N_Compilation_Unit_Aux); - if Nkind (T) = N_Protected_Type_Declaration - and then A_Id /= Aspect_Dispatching_Domain - and then A_Id /= Aspect_CPU - then - pragma Assert - (Present (Protected_Definition (T))); - - L := Visible_Declarations - (Protected_Definition (T)); - - elsif Nkind (T) = N_Task_Type_Declaration then - if No (Task_Definition (T)) then - Set_Task_Definition - (T, - Make_Task_Definition - (Sloc (T), - Visible_Declarations => New_List, - End_Label => Empty)); - end if; + -- For a Boolean aspect, create the corresponding pragma if + -- no expression or if the value is True. - L := Visible_Declarations (Task_Definition (T)); + if Is_Boolean_Aspect (Aspect) + and then No (Aitem) + then + if Is_True (Static_Boolean (Expr)) then + Aitem := + Make_Pragma (Loc, + Pragma_Argument_Associations => New_List (Ent), + Pragma_Identifier => + Make_Identifier (Sloc (Id), Chars (Id))); - else - raise Program_Error; - end if; + Set_From_Aspect_Specification (Aitem, True); + Set_Corresponding_Aspect (Aitem, Aspect); - Prepend (Aitem, To => L); + else + goto Continue; + end if; + end if; - -- Analyze rewritten pragma. Otherwise, its - -- analysis is done too late, after the task or - -- protected object has been created. + if No (Pragmas_After (Aux)) then + Set_Pragmas_After (Aux, Empty_List); + end if; - Analyze (Aitem); - end; + Append (Aitem, Pragmas_After (Aux)); + goto Continue; + end; + end if; - -- For all other cases, insert in sequence + -- The evaluation of the aspect is delayed to the freezing point. + -- The pragma or attribute clause if there is one is then attached + -- to the aspect specification which is placed in the rep item + -- list. - when others => - Insert_After (Ins_Node, Aitem); - Ins_Node := Aitem; - end case; + if Delay_Required then + if Present (Aitem) then + Set_Is_Delayed_Aspect (Aitem); + Set_Aspect_Rep_Item (Aspect, Aitem); + Set_Parent (Aitem, Aspect); end if; + + Set_Is_Delayed_Aspect (Aspect); + Set_Has_Delayed_Aspects (E); + Record_Rep_Item (E, Aspect); + + -- When delay is not required and the context is not a compilation + -- unit, we simply insert the pragma/attribute definition clause + -- in sequence. + + else + Insert_After (Ins_Node, Aitem); + Ins_Node := Aitem; end if; end; <<Continue>> Next (Aspect); end loop Aspect_Loop; + + if Has_Delayed_Aspects (E) then + Ensure_Freeze_Node (E); + end if; end Analyze_Aspect_Specifications; ----------------------- @@ -2293,18 +2058,29 @@ package body Sem_Ch13 is return False; end if; - -- Otherwise current clause may duplicate previous clause or a - -- previously given aspect specification for the same aspect. + -- Otherwise current clause may duplicate previous clause, or a + -- previously given pragma or aspect specification for the same + -- aspect. A := Get_Rep_Item_For_Entity (U_Ent, Chars (N)); if Present (A) then - if Entity (A) = U_Ent then - Error_Msg_Name_1 := Chars (N); - Error_Msg_Sloc := Sloc (A); + Error_Msg_Name_1 := Chars (N); + Error_Msg_Sloc := Sloc (A); + + if Nkind (A) = N_Aspect_Specification + or else From_Aspect_Specification (A) + then Error_Msg_NE ("aspect% for & previously given#", N, U_Ent); - return True; + + elsif Nkind (A) = N_Pragma then + Error_Msg_NE ("clause% for & duplicates pragma#", N, U_Ent); + + else + Error_Msg_NE ("clause% for & duplicates clause#", N, U_Ent); end if; + + return True; end if; return False; @@ -2436,9 +2212,13 @@ package body Sem_Ch13 is if Etype (Nam) = Any_Type then return; - -- Must be declared in current scope + -- Must be declared in current scope or in case of an aspect + -- specification, must be the current scope. - elsif Scope (Ent) /= Current_Scope then + elsif Scope (Ent) /= Current_Scope + and then (not From_Aspect_Specification (N) + or else Ent /= Current_Scope) + then Error_Msg_N ("entity must be declared in this scope", Nam); return; @@ -2963,6 +2743,44 @@ package body Sem_Ch13 is when Attribute_Constant_Indexing => Check_Indexing_Functions; + --------- + -- CPU -- + --------- + + when Attribute_CPU => CPU : + begin + -- CPU attribute definition clause not allowed except from aspect + -- specification. + + if From_Aspect_Specification (N) then + if not Is_Task_Type (U_Ent) then + Error_Msg_N ("CPU can only be defined for task", Nam); + + elsif Duplicate_Clause then + null; + + else + -- The expression must be analyzed in the special manner + -- described in "Handling of Default and Per-Object + -- Expressions" in sem.ads. + + -- The visibility to the discriminants must be restored + + Push_Scope_And_Install_Discriminants (U_Ent); + Preanalyze_Spec_Expression (Expr, RTE (RE_CPU_Range)); + Uninstall_Discriminants_And_Pop_Scope (U_Ent); + + if not Is_Static_Expression (Expr) then + Check_Restriction (Static_Priorities, Expr); + end if; + end if; + + else + Error_Msg_N + ("attribute& cannot be set with definition clause", N); + end if; + end CPU; + ---------------------- -- Default_Iterator -- ---------------------- @@ -2996,6 +2814,45 @@ package body Sem_Ch13 is end if; end Default_Iterator; + ------------------------ + -- Dispatching_Domain -- + ------------------------ + + when Attribute_Dispatching_Domain => Dispatching_Domain : + begin + -- Dispatching_Domain attribute definition clause not allowed + -- except from aspect specification. + + if From_Aspect_Specification (N) then + if not Is_Task_Type (U_Ent) then + Error_Msg_N ("Dispatching_Domain can only be defined" & + "for task", + Nam); + + elsif Duplicate_Clause then + null; + + else + -- The expression must be analyzed in the special manner + -- described in "Handling of Default and Per-Object + -- Expressions" in sem.ads. + + -- The visibility to the discriminants must be restored + + Push_Scope_And_Install_Discriminants (U_Ent); + + Preanalyze_Spec_Expression + (Expr, RTE (RE_Dispatching_Domain)); + + Uninstall_Discriminants_And_Pop_Scope (U_Ent); + end if; + + else + Error_Msg_N + ("attribute& cannot be set with definition clause", N); + end if; + end Dispatching_Domain; + ------------------ -- External_Tag -- ------------------ @@ -3055,6 +2912,48 @@ package body Sem_Ch13 is Analyze_Stream_TSS_Definition (TSS_Stream_Input); Set_Has_Specified_Stream_Input (Ent); + ------------------------ + -- Interrupt_Priority -- + ------------------------ + + when Attribute_Interrupt_Priority => Interrupt_Priority : + begin + -- Interrupt_Priority attribute definition clause not allowed + -- except from aspect specification. + + if From_Aspect_Specification (N) then + if not (Is_Protected_Type (U_Ent) + or else Is_Task_Type (U_Ent)) + then + Error_Msg_N + ("Interrupt_Priority can only be defined for task" & + "and protected object", + Nam); + + elsif Duplicate_Clause then + null; + + else + -- The expression must be analyzed in the special manner + -- described in "Handling of Default and Per-Object + -- Expressions" in sem.ads. + + -- The visibility to the discriminants must be restored + + Push_Scope_And_Install_Discriminants (U_Ent); + + Preanalyze_Spec_Expression + (Expr, RTE (RE_Interrupt_Priority)); + + Uninstall_Discriminants_And_Pop_Scope (U_Ent); + end if; + + else + Error_Msg_N + ("attribute& cannot be set with definition clause", N); + end if; + end Interrupt_Priority; + ---------------------- -- Iterator_Element -- ---------------------- @@ -3147,6 +3046,49 @@ package body Sem_Ch13 is Analyze_Stream_TSS_Definition (TSS_Stream_Output); Set_Has_Specified_Stream_Output (Ent); + -------------- + -- Priority -- + -------------- + + when Attribute_Priority => Priority : + begin + -- Priority attribute definition clause not allowed except from + -- aspect specification. + + if From_Aspect_Specification (N) then + if not (Is_Protected_Type (U_Ent) + or else Is_Task_Type (U_Ent)) + then + Error_Msg_N + ("Priority can only be defined for task and protected" & + "object", + Nam); + + elsif Duplicate_Clause then + null; + + else + -- The expression must be analyzed in the special manner + -- described in "Handling of Default and Per-Object + -- Expressions" in sem.ads. + + -- The visibility to the discriminants must be restored + + Push_Scope_And_Install_Discriminants (U_Ent); + Preanalyze_Spec_Expression (Expr, Standard_Integer); + Uninstall_Discriminants_And_Pop_Scope (U_Ent); + + if not Is_Static_Expression (Expr) then + Check_Restriction (Static_Priorities, Expr); + end if; + end if; + + else + Error_Msg_N + ("attribute& cannot be set with definition clause", N); + end if; + end Priority; + ---------- -- Read -- ---------- @@ -3508,7 +3450,6 @@ package body Sem_Ch13 is when Attribute_Storage_Size => Storage_Size : declare Btype : constant Entity_Id := Base_Type (U_Ent); - Sprag : Node_Id; begin if Is_Task_Type (U_Ent) then @@ -3551,16 +3492,6 @@ package body Sem_Ch13 is then Set_No_Pool_Assigned (Btype); end if; - - else -- Is_Task_Type (U_Ent) - Sprag := Get_Rep_Pragma (Btype, Name_Storage_Size); - - if Present (Sprag) then - Error_Msg_Sloc := Sloc (Sprag); - Error_Msg_N - ("Storage_Size already specified#", Nam); - return; - end if; end if; Set_Has_Storage_Size_Clause (Btype); @@ -4221,7 +4152,14 @@ package body Sem_Ch13 is -- the subtype name in the saved expression so that they will not cause -- trouble in the preanalysis. - if Has_Delayed_Aspects (E) then + if Has_Delayed_Aspects (E) + and then Scope (E) = Current_Scope + then + -- Retrieve the visibility to the discriminants in order to properly + -- analyze the aspects. + + Push_Scope_And_Install_Discriminants (E); + declare Ritem : Node_Id; @@ -4233,7 +4171,6 @@ package body Sem_Ch13 is if Nkind (Ritem) = N_Aspect_Specification and then Entity (Ritem) = E and then Is_Delayed_Aspect (Ritem) - and then Scope (E) = Current_Scope then Check_Aspect_At_Freeze_Point (Ritem); end if; @@ -4241,6 +4178,8 @@ package body Sem_Ch13 is Next_Rep_Item (Ritem); end loop; end; + + Uninstall_Discriminants_And_Pop_Scope (E); end if; end Analyze_Freeze_Entity; @@ -6185,18 +6124,17 @@ package body Sem_Ch13 is procedure Check_Aspect_At_End_Of_Declarations (ASN : Node_Id) is Ent : constant Entity_Id := Entity (ASN); Ident : constant Node_Id := Identifier (ASN); - - Freeze_Expr : constant Node_Id := Expression (ASN); - -- Expression from call to Check_Aspect_At_Freeze_Point + A_Id : constant Aspect_Id := Get_Aspect_Id (Chars (Ident)); End_Decl_Expr : constant Node_Id := Entity (Ident); -- Expression to be analyzed at end of declarations + Freeze_Expr : constant Node_Id := Expression (ASN); + -- Expression from call to Check_Aspect_At_Freeze_Point + T : constant Entity_Id := Etype (Freeze_Expr); -- Type required for preanalyze call - A_Id : constant Aspect_Id := Get_Aspect_Id (Chars (Ident)); - Err : Boolean; -- Set False if error @@ -6206,9 +6144,14 @@ package body Sem_Ch13 is -- preanalyzed just after the freeze point. begin + -- Case of aspects Dimension, Dimension_System and Synchronization + + if A_Id = Aspect_Synchronization then + return; + -- Case of stream attributes, just have to compare entities - if A_Id = Aspect_Input or else + elsif A_Id = Aspect_Input or else A_Id = Aspect_Output or else A_Id = Aspect_Read or else A_Id = Aspect_Write @@ -6286,11 +6229,11 @@ package body Sem_Ch13 is Ident : constant Node_Id := Identifier (ASN); -- Identifier (use Entity field to save expression) - T : Entity_Id; - -- Type required for preanalyze call - A_Id : constant Aspect_Id := Get_Aspect_Id (Chars (Ident)); + T : Entity_Id := Empty; + -- Type required for preanalyze call + begin -- On entry to this procedure, Entity (Ident) contains a copy of the -- original expression from the aspect, saved for this purpose. @@ -6312,34 +6255,17 @@ package body Sem_Ch13 is when No_Aspect => raise Program_Error; - -- Library unit aspects should be impossible (never delayed) - - when Library_Unit_Aspects => - raise Program_Error; + -- Aspects taking an optional boolean argument. - -- Aspects taking an optional boolean argument. Should be impossible - -- since these are never delayed. - - when Boolean_Aspects => - raise Program_Error; - - -- Contract_Case aspects apply to subprograms, hence should never be - -- delayed. - - when Aspect_Contract_Case => - raise Program_Error; - - -- Test_Case aspects apply to entries and subprograms, hence should - -- never be delayed. - - when Aspect_Test_Case => - raise Program_Error; + when Boolean_Aspects | + Library_Unit_Aspects => + T := Standard_Boolean; when Aspect_Attach_Handler => T := RTE (RE_Interrupt_ID); when Aspect_Convention => - null; + return; -- Default_Value is resolved with the type entity in question @@ -6400,13 +6326,19 @@ package body Sem_Ch13 is Aspect_Value_Size => T := Any_Integer; - -- Stream attribute. Special case, the expression is just an entity + when Aspect_Synchronization => + return; + + -- Special case, the expression of these aspects is just an entity -- that does not need any resolution, so just analyze. - when Aspect_Input | - Aspect_Output | - Aspect_Read | - Aspect_Write => + when Aspect_Input | + Aspect_Output | + Aspect_Read | + Aspect_Suppress | + Aspect_Unsuppress | + Aspect_Warnings | + Aspect_Write => Analyze (Expression (ASN)); return; @@ -6416,34 +6348,30 @@ package body Sem_Ch13 is when Aspect_Constant_Indexing | Aspect_Default_Iterator | Aspect_Iterator_Element | - Aspect_Implicit_Dereference | Aspect_Variable_Indexing => Analyze (Expression (ASN)); return; - -- Suppress/Unsuppress/Synchronization/Warnings should not be delayed - - when Aspect_Suppress | - Aspect_Unsuppress | - Aspect_Synchronization | - Aspect_Warnings => - raise Program_Error; - - -- Pre/Post/Invariant/Predicate take boolean expressions + -- Invariant/Predicate take boolean expressions when Aspect_Dynamic_Predicate | Aspect_Invariant | - Aspect_Pre | - Aspect_Precondition | - Aspect_Post | - Aspect_Postcondition | Aspect_Predicate | Aspect_Static_Predicate | Aspect_Type_Invariant => T := Standard_Boolean; - when Aspect_Dimension | - Aspect_Dimension_System => + -- Here is the list of aspects that don't require delay analysis. + + when Aspect_Contract_Case | + Aspect_Dimension | + Aspect_Dimension_System | + Aspect_Implicit_Dereference | + Aspect_Post | + Aspect_Postcondition | + Aspect_Pre | + Aspect_Precondition | + Aspect_Test_Case => raise Program_Error; end case; @@ -7661,6 +7589,227 @@ 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_Value or + -- 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 -- ------------------------- diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads index 742b88dc7d8..136e3755a86 100644 --- a/gcc/ada/sem_ch13.ads +++ b/gcc/ada/sem_ch13.ads @@ -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; diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 76db08c5e4f..ced4d51640d 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -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; diff --git a/gcc/ada/sem_ch9.ads b/gcc/ada/sem_ch9.ads index 5cb7916974a..63f5bee2dea 100644 --- a/gcc/ada/sem_ch9.ads +++ b/gcc/ada/sem_ch9.ads @@ -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 -- ------------------------------ diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index d041ca3a5f0..1193b09209e 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -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,7 +1597,8 @@ package body Sem_Prag is ---------------------------- procedure Check_Duplicate_Pragma (E : Entity_Id) is - P : Node_Id; + Id : Entity_Id := E; + P : Node_Id; begin -- Nothing to do if this pragma comes from an aspect specification, @@ -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); - - 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; @@ -13877,7 +13905,8 @@ package body Sem_Prag is -- pragma Task_Info (EXPRESSION); when Pragma_Task_Info => Task_Info : declare - P : constant Node_Id := Parent (N); + 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; -------------------- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 3c0e6c41426..34bd4524b53 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -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 - Error_Msg_NEL - ("\?& will be raised for objects of this type", - N, Standard_Constraint_Error, Eloc); + 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", diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 9c6b6888b21..d1c1480858a 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -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 diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 76204498da0..cfaa82842c9 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -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); diff --git a/gcc/ada/snames.adb-tmpl b/gcc/ada/snames.adb-tmpl index 7abf4ab6845..0beb51fd1e9 100644 --- a/gcc/ada/snames.adb-tmpl +++ b/gcc/ada/snames.adb-tmpl @@ -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 diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index b8e381520b7..4b1b337d036 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -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 diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index 32c327506a4..51cec6e02c4 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -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; |