This patch creates the fields _CPU, _Priority and _Dispatching_Domain in tasks' corresponding records when a rep item (pragm/attribute definition clause/aspect specification) for this aspect is present.
Tested on x86_64-pc-linux-gnu, committed on trunk 2012-06-26 Vincent Pucci <pu...@adacore.com> * exp_ch3.adb (Build_Init_Statements): Don't check the parents in the Rep Item Chain of the task for aspects Interrupt_Priority, Priority, CPU and Dispatching_Domain. * exp_ch9.adb (Expand_N_Task_Type_Declaration): fields _Priority, _CPU and _Domain are present in the corresponding record type only if the task entity has a pragma, attribute definition clause or aspect specification. (Make_Initialize_Protection): Don't check the parents in the Rep Item Chain of the task for aspects Interrupt_Priority, Priority, CPU and Dispatching_Domain. * freeze.adb (Freeze_Entity): Use of Evaluate_Aspects_At_Freeze_Point call replaced by Analyze_Aspects_At_Freeze_Point. * sem_ch13.adb, sem_ch13.ads (Analyze_Aspects_At_Freeze_Point): Renaming of Evaluate_Aspects_At_Freeze_Point.
Index: exp_ch9.adb =================================================================== --- exp_ch9.adb (revision 188984) +++ exp_ch9.adb (working copy) @@ -11270,30 +11270,36 @@ -- in the pragma, and is used to override the task stack size otherwise -- associated with the task type. - -- The _Priority field is always present. It will be filled at the freeze - -- point, when the record init proc is built, to capture the expression of - -- a Priority pragma, attribute definition clause or aspect specification - -- (see Build_Record_Init_Proc in Exp_Ch3). + -- The _Priority field is present only if the task entity has a Priority or + -- Interrupt_Priority rep item (pragma, aspect specification or attribute + -- definition clause). It will be filled at the freeze point, when the + -- record init proc is built, to capture the expression of the rep item + -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled + -- here since aspect evaluations are delayed till the freeze point. -- The _Task_Info field is present only if a Task_Info pragma appears in -- the task definition. The expression captures the argument that was -- present in the pragma, and is used to provide the Task_Image parameter -- to the call to Create_Task. - -- The _CPU field is always present. It will be filled at the freeze point, - -- when the record init proc is built, to capture the expression of a CPU - -- pragma, attribute definition clause or aspect specification (see - -- Build_Record_Init_Proc in Exp_Ch3). + -- The _CPU field is present only if the task entity has a CPU rep item + -- (pragma, aspect specification or attribute definition clause). It will + -- be filled at the freeze point, when the record init proc is built, to + -- capture the expression of the rep item (see Build_Record_Init_Proc in + -- Exp_Ch3). Note that it cannot be filled here since aspect evaluations + -- are delayed till the freeze point. -- The _Relative_Deadline field is present only if a Relative_Deadline -- pragma appears in the task definition. The expression captures the -- argument that was present in the pragma, and is used to provide the -- Relative_Deadline parameter to the call to Create_Task. - -- The _Domain field is always present. It will be filled at the freeze - -- point, when the record init proc is built, to capture the expression of - -- a Dispatching_Domain pragma, attribute definition clause or aspect - -- specification (see Build_Record_Init_Proc in Exp_Ch3). + -- The _Domain field is present only if the task entity has a + -- Dispatching_Domain rep item (pragma, aspect specification or attribute + -- definition clause). It will be filled at the freeze point, when the + -- record init proc is built, to capture the expression of the rep item + -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled + -- here since aspect evaluations are delayed till the freeze point. -- When a task is declared, an instance of the task value record is -- created. The elaboration of this declaration creates the correct bounds @@ -11566,17 +11572,20 @@ Collect_Entry_Families (Loc, Cdecls, Size_Decl, Tasktyp); - -- Add the _Priority component with no expression + -- Add the _Priority component if a Interrupt_Priority or Priority rep + -- item is present. - Append_To (Cdecls, - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uPriority), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Reference_To (Standard_Integer, Loc)))); + if Has_Rep_Item (TaskId, Name_Priority, Check_Parents => False) then + Append_To (Cdecls, + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uPriority), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Reference_To (Standard_Integer, Loc)))); + end if; -- Add the _Size component if a Storage_Size pragma is present @@ -11623,18 +11632,20 @@ (TaskId, Name_Task_Info, Check_Parents => False))))))); end if; - -- Add the _CPU component with no expression + -- Add the _CPU component if a CPU rep item is present - Append_To (Cdecls, - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uCPU), + if Has_Rep_Item (TaskId, Name_CPU, Check_Parents => False) then + Append_To (Cdecls, + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uCPU), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Reference_To (RTE (RE_CPU_Range), Loc)))); + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Reference_To (RTE (RE_CPU_Range), Loc)))); + end if; -- Add the _Relative_Deadline component if a Relative_Deadline pragma is -- present. If we are using a restricted run time this component will @@ -11663,11 +11674,16 @@ Get_Relative_Deadline_Pragma (Taskdef)))))))); end if; - -- Add the _Dispatching_Domain component with no expression. If we are - -- using a restricted run time this component will not be added - -- (dispatching domains are not allowed by the Ravenscar profile). + -- Add the _Dispatching_Domain component if a Dispatching_Domain rep + -- item is present. If we are using a restricted run time this component + -- will not be added (dispatching domains are not allowed by the + -- Ravenscar profile). - if not Restricted_Profile then + if not Restricted_Profile + and then + Has_Rep_Item + (TaskId, Name_Dispatching_Domain, Check_Parents => False) + then Append_To (Cdecls, Make_Component_Declaration (Loc, Defining_Identifier => @@ -13344,10 +13360,11 @@ -- Interrupt_Priority'Last, an implementation-defined value, see -- (RM D.3(10)). - if Has_Rep_Item (Ptyp, Name_Priority) then + if Has_Rep_Item (Ptyp, Name_Priority, Check_Parents => False) then declare Prio_Clause : constant Node_Id := - Get_Rep_Item (Ptyp, Name_Priority); + Get_Rep_Item + (Ptyp, Name_Priority, Check_Parents => False); Prio : Node_Id; Temp : Entity_Id; @@ -13670,7 +13687,7 @@ -- Priority parameter. Set to Unspecified_Priority unless there is a -- Priority rep item, in which case we take the value from the rep item. - if Has_Rep_Item (Ttyp, Name_Priority) then + if Has_Rep_Item (Ttyp, Name_Priority, Check_Parents => False) then Append_To (Args, Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_uInit), @@ -13741,7 +13758,7 @@ -- passed as an Integer because in the case of unspecified CPU the -- value is not in the range of CPU_Range. - if Has_Rep_Item (Ttyp, Name_CPU) then + if Has_Rep_Item (Ttyp, Name_CPU, Check_Parents => False) then Append_To (Args, Convert_To (Standard_Integer, Make_Selected_Component (Loc, @@ -13790,7 +13807,9 @@ -- Case where Dispatching_Domain rep item applies: use given value - if Has_Rep_Item (Ttyp, Name_Dispatching_Domain) then + if Has_Rep_Item + (Ttyp, Name_Dispatching_Domain, Check_Parents => False) + then Append_To (Args, Make_Selected_Component (Loc, Prefix => Index: freeze.adb =================================================================== --- freeze.adb (revision 188984) +++ freeze.adb (working copy) @@ -2525,14 +2525,14 @@ end if; -- Deal with delayed aspect specifications. The analysis of the - -- aspect is required to be delayed to the freeze point, so we - -- evaluate the pragma or attribute definition clause in the tree at + -- aspect is required to be delayed to the freeze point, thus we + -- analyze the pragma or attribute definition clause in the tree at -- this point. We also analyze the aspect specification node at the -- freeze point when the aspect doesn't correspond to -- pragma/attribute definition clause. if Has_Delayed_Aspects (E) then - Evaluate_Aspects_At_Freeze_Point (E); + Analyze_Aspects_At_Freeze_Point (E); end if; -- Here to freeze the entity Index: sem_ch13.adb =================================================================== --- sem_ch13.adb (revision 188984) +++ sem_ch13.adb (working copy) @@ -682,6 +682,227 @@ end if; end Alignment_Check_For_Size_Change; + ------------------------------------- + -- Analyze_Aspects_At_Freeze_Point -- + ------------------------------------- + + procedure Analyze_Aspects_At_Freeze_Point (E : Entity_Id) is + ASN : Node_Id; + A_Id : Aspect_Id; + Ritem : Node_Id; + + procedure Analyze_Aspect_Default_Value (ASN : Node_Id); + -- This routine analyzes an Aspect_Default_[Component_]Value denoted by + -- the aspect specification node ASN. + + procedure Make_Pragma_From_Boolean_Aspect (ASN : Node_Id); + -- Given an aspect specification node ASN whose expression is an + -- optional Boolean, this routines creates the corresponding pragma + -- at the freezing point. + + ---------------------------------- + -- Analyze_Aspect_Default_Value -- + ---------------------------------- + + procedure Analyze_Aspect_Default_Value (ASN : Node_Id) is + Ent : constant Entity_Id := Entity (ASN); + Expr : constant Node_Id := Expression (ASN); + Id : constant Node_Id := Identifier (ASN); + + begin + Error_Msg_Name_1 := Chars (Id); + + if not Is_Type (Ent) then + Error_Msg_N ("aspect% can only apply to a type", Id); + return; + + elsif not Is_First_Subtype (Ent) then + Error_Msg_N ("aspect% cannot apply to subtype", Id); + return; + + elsif A_Id = Aspect_Default_Value + and then not Is_Scalar_Type (Ent) + then + Error_Msg_N ("aspect% can only be applied to scalar type", Id); + return; + + elsif A_Id = Aspect_Default_Component_Value then + if not Is_Array_Type (Ent) then + Error_Msg_N ("aspect% can only be applied to array type", Id); + return; + + elsif not Is_Scalar_Type (Component_Type (Ent)) then + Error_Msg_N ("aspect% requires scalar components", Id); + return; + end if; + end if; + + Set_Has_Default_Aspect (Base_Type (Ent)); + + if Is_Scalar_Type (Ent) then + Set_Default_Aspect_Value (Ent, Expr); + else + Set_Default_Aspect_Component_Value (Ent, Expr); + end if; + end Analyze_Aspect_Default_Value; + + ------------------------------------- + -- Make_Pragma_From_Boolean_Aspect -- + ------------------------------------- + + procedure Make_Pragma_From_Boolean_Aspect (ASN : Node_Id) is + Ident : constant Node_Id := Identifier (ASN); + A_Name : constant Name_Id := Chars (Ident); + A_Id : constant Aspect_Id := Get_Aspect_Id (A_Name); + Ent : constant Entity_Id := Entity (ASN); + Expr : constant Node_Id := Expression (ASN); + Loc : constant Source_Ptr := Sloc (ASN); + + Prag : Node_Id; + + procedure Check_False_Aspect_For_Derived_Type; + -- This procedure checks for the case of a false aspect for a derived + -- type, which improperly tries to cancel an aspect inherited from + -- the parent. + + ----------------------------------------- + -- Check_False_Aspect_For_Derived_Type -- + ----------------------------------------- + + procedure Check_False_Aspect_For_Derived_Type is + Par : Node_Id; + + begin + -- We are only checking derived types + + if not Is_Derived_Type (E) then + return; + end if; + + Par := Nearest_Ancestor (E); + + case A_Id is + when Aspect_Atomic | Aspect_Shared => + if not Is_Atomic (Par) then + return; + end if; + + when Aspect_Atomic_Components => + if not Has_Atomic_Components (Par) then + return; + end if; + + when Aspect_Discard_Names => + if not Discard_Names (Par) then + return; + end if; + + when Aspect_Pack => + if not Is_Packed (Par) then + return; + end if; + + when Aspect_Unchecked_Union => + if not Is_Unchecked_Union (Par) then + return; + end if; + + when Aspect_Volatile => + if not Is_Volatile (Par) then + return; + end if; + + when Aspect_Volatile_Components => + if not Has_Volatile_Components (Par) then + return; + end if; + + when others => + return; + end case; + + -- Fall through means we are canceling an inherited aspect + + Error_Msg_Name_1 := A_Name; + Error_Msg_NE ("derived type& inherits aspect%, cannot cancel", + Expr, + E); + + end Check_False_Aspect_For_Derived_Type; + + -- Start of processing for Make_Pragma_From_Boolean_Aspect + + begin + if Is_False (Static_Boolean (Expr)) then + Check_False_Aspect_For_Derived_Type; + + else + Prag := + Make_Pragma (Loc, + Pragma_Argument_Associations => New_List ( + New_Occurrence_Of (Ent, Sloc (Ident))), + Pragma_Identifier => + Make_Identifier (Sloc (Ident), Chars (Ident))); + + Set_From_Aspect_Specification (Prag, True); + Set_Corresponding_Aspect (Prag, ASN); + Set_Aspect_Rep_Item (ASN, Prag); + Set_Is_Delayed_Aspect (Prag); + Set_Parent (Prag, ASN); + end if; + + end Make_Pragma_From_Boolean_Aspect; + + -- Start of processing for Analyze_Aspects_At_Freeze_Point + + begin + -- Must be declared in current scope. This is need for a generic + -- context. + + if Scope (E) /= Current_Scope then + return; + end if; + + -- Look for aspect specification entries for this entity + + ASN := First_Rep_Item (E); + + while Present (ASN) loop + if Nkind (ASN) = N_Aspect_Specification + and then Entity (ASN) = E + and then Is_Delayed_Aspect (ASN) + then + A_Id := Get_Aspect_Id (Chars (Identifier (ASN))); + + case A_Id is + -- For aspects whose expression is an optional Boolean, make + -- the corresponding pragma at the freezing point. + + when Boolean_Aspects | + Library_Unit_Aspects => + Make_Pragma_From_Boolean_Aspect (ASN); + + -- Special handling for aspects that don't correspond to + -- pragmas/attributes. + + when Aspect_Default_Value | + Aspect_Default_Component_Value => + Analyze_Aspect_Default_Value (ASN); + + when others => null; + end case; + + Ritem := Aspect_Rep_Item (ASN); + + if Present (Ritem) then + Analyze (Ritem); + end if; + end if; + + Next_Rep_Item (ASN); + end loop; + end Analyze_Aspects_At_Freeze_Point; + ----------------------------------- -- Analyze_Aspect_Specifications -- ----------------------------------- @@ -1199,7 +1420,6 @@ -- declaration. We do not have to worry about delay issues -- since the pragma processing takes care of this. - Set_Is_Delayed_Aspect (Aspect); Delay_Required := False; -- Case 3 : Aspects that don't correspond to pragma/attribute @@ -7602,226 +7822,6 @@ end if; end Check_Size; - -------------------------------------- - -- Evaluate_Aspects_At_Freeze_Point -- - -------------------------------------- - - procedure Evaluate_Aspects_At_Freeze_Point (E : Entity_Id) is - ASN : Node_Id; - A_Id : Aspect_Id; - Ritem : Node_Id; - - procedure Analyze_Aspect_Default_Value (ASN : Node_Id); - -- This routine analyzes an Aspect_Default_[Component_]Value denoted by - -- the aspect specification node ASN. - - procedure Make_Pragma_From_Boolean_Aspect (ASN : Node_Id); - -- Given an aspect specification node ASN whose expression is an - -- optional Boolean, this routines creates the corresponding pragma - -- at the freezing point. - - ---------------------------------- - -- Analyze_Aspect_Default_Value -- - ---------------------------------- - - procedure Analyze_Aspect_Default_Value (ASN : Node_Id) is - Ent : constant Entity_Id := Entity (ASN); - Expr : constant Node_Id := Expression (ASN); - Id : constant Node_Id := Identifier (ASN); - - begin - Error_Msg_Name_1 := Chars (Id); - - if not Is_Type (Ent) then - Error_Msg_N ("aspect% can only apply to a type", Id); - return; - - elsif not Is_First_Subtype (Ent) then - Error_Msg_N ("aspect% cannot apply to subtype", Id); - return; - - elsif A_Id = Aspect_Default_Value - and then not Is_Scalar_Type (Ent) - then - Error_Msg_N ("aspect% can only be applied to scalar type", Id); - return; - - elsif A_Id = Aspect_Default_Component_Value then - if not Is_Array_Type (Ent) then - Error_Msg_N ("aspect% can only be applied to array type", Id); - return; - - elsif not Is_Scalar_Type (Component_Type (Ent)) then - Error_Msg_N ("aspect% requires scalar components", Id); - return; - end if; - end if; - - Set_Has_Default_Aspect (Base_Type (Ent)); - - if Is_Scalar_Type (Ent) then - Set_Default_Aspect_Value (Ent, Expr); - else - Set_Default_Aspect_Component_Value (Ent, Expr); - end if; - end Analyze_Aspect_Default_Value; - - ------------------------------------- - -- Make_Pragma_From_Boolean_Aspect -- - ------------------------------------- - - procedure Make_Pragma_From_Boolean_Aspect (ASN : Node_Id) is - Ident : constant Node_Id := Identifier (ASN); - A_Name : constant Name_Id := Chars (Ident); - A_Id : constant Aspect_Id := Get_Aspect_Id (A_Name); - Ent : constant Entity_Id := Entity (ASN); - Expr : constant Node_Id := Expression (ASN); - Loc : constant Source_Ptr := Sloc (ASN); - - Prag : Node_Id; - - procedure Check_False_Aspect_For_Derived_Type; - -- This procedure checks for the case of a false aspect for a derived - -- type, which improperly tries to cancel an aspect inherited from - -- the parent. - - ----------------------------------------- - -- Check_False_Aspect_For_Derived_Type -- - ----------------------------------------- - - procedure Check_False_Aspect_For_Derived_Type is - Par : Node_Id; - - begin - -- We are only checking derived types - - if not Is_Derived_Type (E) then - return; - end if; - - Par := Nearest_Ancestor (E); - - case A_Id is - when Aspect_Atomic | Aspect_Shared => - if not Is_Atomic (Par) then - return; - end if; - - when Aspect_Atomic_Components => - if not Has_Atomic_Components (Par) then - return; - end if; - - when Aspect_Discard_Names => - if not Discard_Names (Par) then - return; - end if; - - when Aspect_Pack => - if not Is_Packed (Par) then - return; - end if; - - when Aspect_Unchecked_Union => - if not Is_Unchecked_Union (Par) then - return; - end if; - - when Aspect_Volatile => - if not Is_Volatile (Par) then - return; - end if; - - when Aspect_Volatile_Components => - if not Has_Volatile_Components (Par) then - return; - end if; - - when others => - return; - end case; - - -- Fall through means we are canceling an inherited aspect - - Error_Msg_Name_1 := A_Name; - Error_Msg_NE ("derived type& inherits aspect%, cannot cancel", - Expr, - E); - - end Check_False_Aspect_For_Derived_Type; - - -- Start of processing for Make_Pragma_From_Boolean_Aspect - - begin - if Is_False (Static_Boolean (Expr)) then - Check_False_Aspect_For_Derived_Type; - - else - Prag := - Make_Pragma (Loc, - Pragma_Argument_Associations => New_List ( - New_Occurrence_Of (Ent, Sloc (Ident))), - Pragma_Identifier => - Make_Identifier (Sloc (Ident), Chars (Ident))); - - Set_From_Aspect_Specification (Prag, True); - Set_Corresponding_Aspect (Prag, ASN); - Set_Aspect_Rep_Item (ASN, Prag); - Set_Is_Delayed_Aspect (Prag); - Set_Parent (Prag, ASN); - end if; - - end Make_Pragma_From_Boolean_Aspect; - - -- Start of processing for Evaluate_Aspects_At_Freeze_Point - - begin - -- Must be declared in current scope - - if Scope (E) /= Current_Scope then - return; - end if; - - -- Look for aspect specification entries for this entity - - ASN := First_Rep_Item (E); - - while Present (ASN) loop - if Nkind (ASN) = N_Aspect_Specification - and then Entity (ASN) = E - and then Is_Delayed_Aspect (ASN) - then - A_Id := Get_Aspect_Id (Chars (Identifier (ASN))); - - case A_Id is - -- For aspects whose expression is an optional Boolean, make - -- the corresponding pragma at the freezing point. - - when Boolean_Aspects | - Library_Unit_Aspects => - Make_Pragma_From_Boolean_Aspect (ASN); - - -- Special handling for aspects that don't correspond to - -- pragmas/attributes. - - when Aspect_Default_Value | - Aspect_Default_Component_Value => - Analyze_Aspect_Default_Value (ASN); - - when others => null; - end case; - - Ritem := Aspect_Rep_Item (ASN); - - if Present (Ritem) then - Analyze (Ritem); - end if; - end if; - - Next_Rep_Item (ASN); - end loop; - end Evaluate_Aspects_At_Freeze_Point; - ------------------------- -- Get_Alignment_Value -- ------------------------- Index: sem_ch13.ads =================================================================== --- sem_ch13.ads (revision 188984) +++ sem_ch13.ads (working copy) @@ -299,6 +299,9 @@ -- Quite an awkward procedure, but this is an awkard requirement! + procedure Analyze_Aspects_At_Freeze_Point (E : Entity_Id); + -- Analyze all the delayed aspects for entity E at freezing point + procedure Check_Aspect_At_Freeze_Point (ASN : Node_Id); -- Performs the processing described above at the freeze point, ASN is the -- N_Aspect_Specification node for the aspect. @@ -307,7 +310,4 @@ -- Performs the processing described above at the freeze all point, and -- issues appropriate error messages if the visibility has indeed changed. -- Again, ASN is the N_Aspect_Specification node for the aspect. - - procedure Evaluate_Aspects_At_Freeze_Point (E : Entity_Id); - -- Evaluates all the delayed aspects for entity E at freezing point end Sem_Ch13; Index: exp_ch3.adb =================================================================== --- exp_ch3.adb (revision 188984) +++ exp_ch3.adb (working copy) @@ -2668,7 +2668,9 @@ Ritem := Get_Rep_Item - (Corresponding_Concurrent_Type (Scope (Id)), Nam); + (Corresponding_Concurrent_Type (Scope (Id)), + Nam, + Check_Parents => False); if Present (Ritem) then