+2011-08-31 Jose Ruiz <ruiz@adacore.com>
+
+ * aspects.ads (Aspect_Id, Aspect_Argument, Aspect_Names): Add the
+ dispatching domain aspect.
+ * aspects.adb (Canonical_Aspect): Add entry for the dispatching domain
+ aspect.
+ * sem_ch13.adb (Analyze_Aspect_Specifications): Analyze the
+ Dispatching_Domain aspect in a similar way as we do for the Priority
+ aspect.
+ * exp_ch9.adb (Expand_N_Task_Type_Declaration): Add the
+ Dispatching_Domain component if a Dispatching_Domain pragma or aspect
+ is present.
+ (Make_Task_Create_Call): Add the Dispatching_Domain when creating a task
+ * par-prag.adb (Prag): Add Pragma_Dispatching_Domain as a known pragma.
+ * sem_prag.adb (Analyze_Pragma): Check the correctness of a pragma
+ Dispatching_Domain and add it to the task definition.
+ (Sig_Flags): Add Pragma_Dispatching_Domain.
+ * rtsfind.ads, rtsfind.adb (RTU_Id, RE_Id, Get_Unit_Name): Add the
+ support to find the types Dispatching_Domain and
+ Dispatching_Domain_Access.
+ * sinfo.ads, sinfo.adb (Has_Pragma_Dispatching_Domain,
+ Set_Has_Pragma_Dispatching_Domain): Add these subprograms to set and
+ query the availability of a pragma Dispatching_Domain.
+ * snames.ads-tmpl (Name_uDispatching_Domain): Add this name required by
+ the expander to pass the Dispatching_Domain when creating a task.
+ (Name_Dispatching_Domain): Add this new name for a pragma.
+ (Pragma_Id): Add the new Pragma_Dispatching_Domain.
+ * s-tassta.ads, s-tassta.adb (Create_Task): Set the domain to which the
+ task has been allocated at creation time.
+ * s-tarest.adb (Create_Restricted_Task): The dispatching domain using
+ Ravenscar is always null.
+ * s-taskin.ads, s-taskin.adb (Initialize_ATCB): Set the domain to which
+ the task has been allocated at creation time.
+ * s-tporft.adb (Register_Foreign_Thread): A foreign task will not have
+ a specific dispatching domain.
+ * s-taprop-linux.adb, s-taprop-solaris.adb, s-taprop-vxworks.adb,
+ s-taprop-mingw.adb (Create_Task): Check whether both Dispatching_Domain
+ and CPU are specified for the task, and the CPU value is not contained
+ within the range of processors for the domain.
+
+2011-08-31 Vincent Celier <celier@adacore.com>
+
+ * make.adb (Original_Gcc) : New constant String_Access.
+ (Gnatmake): For VM targets, do not use VM version of the compiler if
+ --GCC= has been specified.
+
+2011-08-31 Thomas Quinot <quinot@adacore.com>
+
+ * sem_ch5.adb: Minor reformatting.
+
+2011-08-31 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_pakd.adb (Convert_To_PAT_Type): If prefix is a function call, do
+ not reanalyze it.
+
+2011-08-31 Bob Duff <duff@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Selected_Component): Use the full type, in case
+ the access type is private; we don't care about privacy in expansion.
+
+2011-08-31 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_aggr.adb (Resolve_Aggregate): In an instance, ignore aggregate
+ subcomponents tnat may be limited, because they originate in view
+ conflicts. If the original aggregate is legal and the actuals are
+ legal, the aggregate itself is legal.
+
2011-08-31 Matthew Heaney <heaney@adacore.com>
* a-rbtgbo.adb (Clear_Tree): Assert representation invariant for lock
Aspect_Default_Iterator => Aspect_Default_Iterator,
Aspect_Default_Value => Aspect_Default_Value,
Aspect_Discard_Names => Aspect_Discard_Names,
+ Aspect_Dispatching_Domain => Aspect_Dispatching_Domain,
Aspect_Dynamic_Predicate => Aspect_Predicate,
Aspect_External_Tag => Aspect_External_Tag,
Aspect_Favor_Top_Level => Aspect_Favor_Top_Level,
Aspect_Default_Component_Value,
Aspect_Default_Iterator,
Aspect_Default_Value,
+ Aspect_Dispatching_Domain,
Aspect_Dynamic_Predicate,
Aspect_External_Tag,
Aspect_Implicit_Dereference,
Aspect_Default_Component_Value => Expression,
Aspect_Default_Iterator => Name,
Aspect_Default_Value => Expression,
+ Aspect_Dispatching_Domain => Expression,
Aspect_Dynamic_Predicate => Expression,
Aspect_External_Tag => Expression,
Aspect_Implicit_Dereference => Name,
Aspect_Default_Value => Name_Default_Value,
Aspect_Default_Component_Value => Name_Default_Component_Value,
Aspect_Discard_Names => Name_Discard_Names,
+ Aspect_Dispatching_Domain => Name_Dispatching_Domain,
Aspect_Dynamic_Predicate => Name_Dynamic_Predicate,
Aspect_Elaborate_Body => Name_Elaborate_Body,
Aspect_External_Tag => Name_External_Tag,
-- Insert explicit dereference if required
if Is_Access_Type (Ptyp) then
+ Set_Etype (P, Ptyp); -- in case it's private
Insert_Explicit_Dereference (P);
Analyze_And_Resolve (P, Designated_Type (Ptyp));
-- values of this task. The general form of this type declaration is
-- type taskV (discriminants) is record
- -- _Task_Id : Task_Id;
- -- entry_family : array (bounds) of Void;
- -- _Priority : Integer := priority_expression;
- -- _Size : Size_Type := Size_Type (size_expression);
- -- _Task_Info : Task_Info_Type := task_info_expression;
- -- _CPU : Integer := cpu_range_expression;
+ -- _Task_Id : Task_Id;
+ -- entry_family : array (bounds) of Void;
+ -- _Priority : Integer := priority_expression;
+ -- _Size : Size_Type := size_expression;
+ -- _Task_Info : Task_Info_Type := task_info_expression;
+ -- _CPU : Integer := cpu_range_expression;
+ -- _Relative_Deadline : Time_Span := time_span_expression;
+ -- _Domain : Dispatching_Domain := dd_expression;
-- end record;
-- The discriminants are present only if the corresponding task type has
-- 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.
+
-- When a task is declared, an instance of the task value record is
-- created. The elaboration of this declaration creates the correct bounds
-- for the entry families, and also evaluates the size, priority, and
(Taskdef, Name_Relative_Deadline))))))));
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).
+
+ if not Restricted_Profile
+ and then Present (Taskdef)
+ and then Has_Pragma_Dispatching_Domain (Taskdef)
+ then
+ Append_To (Cdecls,
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uDispatching_Domain),
+
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ 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))))))));
+ end if;
+
Insert_After (Size_Decl, Rec_Decl);
-- Analyze the record declaration immediately after construction,
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.
+
+ -- Case where pragma or aspect Dispatching_Domain applies: use given
+ -- value.
+
+ if Present (Tdef) and then Has_Pragma_Dispatching_Domain (Tdef) then
+ Append_To (Args,
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Name_uInit),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uDispatching_Domain)));
+
+ -- No pragma or aspect Dispatching_Domain apply to the task
+
+ else
+ Append_To (Args, Make_Null (Loc));
+ end if;
+
-- Number of entries. This is an expression of the form:
-- n + _Init.a'Length + _Init.a'B'Length + ...
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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- --
-- see Reset_Packed_Prefix. On the other hand, if the prefix is a simple
-- array reference, reanalysis can produce spurious type errors when the
-- PAT type is replaced again with the original type of the array. Same
- -- for the case of a dereference. The following is correct and minimal,
+ -- for the case of a dereference. Ditto for function calls: expansion
+ -- may introduce additional actuals which will trigger errors if call
+ -- is reanalyzed. The following is correct and minimal,
-- but the handling of more complex packed expressions in actuals is
-- confused. Probably the problem only remains for actuals in calls.
(Nkind (Aexp) = N_Indexed_Component
and then Is_Entity_Name (Prefix (Aexp)))
or else Nkind (Aexp) = N_Explicit_Dereference
+ or else Nkind (Aexp) = N_Function_Call
then
Set_Analyzed (Aexp);
end if;
-- Compiler, Binder & Linker Data and Subprograms --
----------------------------------------------------
- Gcc : String_Access := Program_Name ("gcc", "gnatmake");
+ Gcc : String_Access := Program_Name ("gcc", "gnatmake");
+ Original_Gcc : constant String_Access := Gcc;
+ -- Original_Gcc is used to check if Gcc has been modified by a switch
+ -- --GCC=, so that for VM platforms, it is not modified again, as it can
+ -- result in incorrect error messages if the compiler cannot be found.
+
Gnatbind : String_Access := Program_Name ("gnatbind", "gnatmake");
Gnatlink : String_Access := Program_Name ("gnatlink", "gnatmake");
-- Default compiler, binder, linker programs
Gnatlink := Saved_Gnatlink;
end if;
- Gcc_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gcc.all);
- Gnatbind_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gnatbind.all);
- Gnatlink_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gnatlink.all);
-
Bad_Compilation.Init;
-- If project files are used, create the mapping of all the sources, so
-- instead.
Check_Object_Consistency := False;
- Gcc := new String'("jvm-gnatcompile");
+
+ -- Do not modify Gcc is --GCC= was specified
+
+ if Gcc = Original_Gcc then
+ Gcc := new String'("jvm-gnatcompile");
+ end if;
when Targparm.CLI_Target =>
- Gcc := new String'("dotnet-gnatcompile");
+ -- Do not modify Gcc is --GCC= was specified
+
+ if Gcc = Original_Gcc then
+ Gcc := new String'("dotnet-gnatcompile");
+ end if;
when Targparm.No_VM =>
raise Program_Error;
end case;
end if;
+ Gcc_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gcc.all);
+ Gnatbind_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gnatbind.all);
+ Gnatlink_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gnatlink.all);
+
-- If we have specified -j switch both from the project file
-- and on the command line, the one from the command line takes
-- precedence.
Pragma_Default_Storage_Pool |
Pragma_Dimension |
Pragma_Discard_Names |
+ Pragma_Dispatching_Domain |
Pragma_Eliminate |
Pragma_Elaborate |
Pragma_Elaborate_All |
elsif U_Id in System_Child then
Name_Buffer (7) := '.';
+ if U_Id in System_Multiprocessors_Child then
+ Name_Buffer (23) := '.';
+ end if;
+
if U_Id in System_Storage_Pools_Child then
Name_Buffer (21) := '.';
end if;
System_WWd_Enum,
System_WWd_Wchar,
+ -- Children of System.Multiprocessors
+
+ System_Multiprocessors_Dispatching_Domains,
+
-- Children of System.Storage_Pools
System_Storage_Pools_Subpools,
range System_Address_Image .. System_Tasking_Stages;
-- Range of values for children or grandchildren of System
+ subtype System_Multiprocessors_Child is RTU_Id
+ range System_Multiprocessors_Dispatching_Domains ..
+ System_Multiprocessors_Dispatching_Domains;
+ -- Range of values for children of System.Multiprocessors
+
subtype System_Storage_Pools_Child is RTU_Id
range System_Storage_Pools_Subpools .. System_Storage_Pools_Subpools;
RE_Unspecified_CPU, -- System.Tasking
+ RE_Dispatching_Domain_Access, -- System.Tasking
+
RE_Abort_Defer, -- System.Soft_Links
RE_Abort_Undefer, -- System.Soft_Links
RE_Complete_Master, -- System.Soft_Links
RE_Width_Wide_Character, -- System.Wid_WChar
RE_Width_Wide_Wide_Character, -- System.Wid_WChar
+ RE_Dispatching_Domain, -- Dispatching_Domains
+
RE_Protected_Entry_Body_Array, -- Tasking.Protected_Objects.Entries
RE_Protection_Entries, -- Tasking.Protected_Objects.Entries
RE_Protection_Entries_Access, -- Tasking.Protected_Objects.Entries
RE_Unspecified_CPU => System_Tasking,
+ RE_Dispatching_Domain_Access => System_Tasking,
+
RE_Abort_Defer => System_Soft_Links,
RE_Abort_Undefer => System_Soft_Links,
RE_Complete_Master => System_Soft_Links,
RE_Width_Wide_Character => System_Wid_WChar,
RE_Width_Wide_Wide_Character => System_Wid_WChar,
+ RE_Dispatching_Domain =>
+ System_Multiprocessors_Dispatching_Domains,
+
RE_Protected_Entry_Body_Array =>
System_Tasking_Protected_Objects_Entries,
RE_Protection_Entries =>
use type System.Multiprocessors.CPU_Range;
begin
+ -- Check whether both Dispatching_Domain and CPU are specified for the
+ -- task, and the CPU value is not contained within the range of
+ -- processors for the domain.
+
+ if T.Common.Domain /= null and then
+ (T.Common.Base_CPU not in T.Common.Domain'Range
+ or else not T.Common.Domain (T.Common.Base_CPU))
+ then
+ Succeeded := False;
+ return;
+ end if;
+
Adjusted_Stack_Size :=
Interfaces.C.size_t (Stack_Size + Alternate_Stack_Size);
Result : DWORD;
Entry_Point : PTHREAD_START_ROUTINE;
- use type System.Multiprocessors.CPU_Range;
-
begin
+ -- Check whether both Dispatching_Domain and CPU are specified for the
+ -- task, and the CPU value is not contained within the range of
+ -- processors for the domain.
+
+ if T.Common.Domain /= null and then
+ (T.Common.Base_CPU not in T.Common.Domain'Range
+ or else not T.Common.Domain (T.Common.Base_CPU))
+ then
+ Succeeded := False;
+ return;
+ end if;
+
pTaskParameter := To_Address (T);
Entry_Point := To_PTHREAD_START_ROUTINE (Wrapper);
use System.Task_Info;
begin
+ -- Check whether both Dispatching_Domain and CPU are specified for the
+ -- task, and the CPU value is not contained within the range of
+ -- processors for the domain.
+
+ if T.Common.Domain /= null and then
+ (T.Common.Base_CPU not in T.Common.Domain'Range
+ or else not T.Common.Domain (T.Common.Base_CPU))
+ then
+ Succeeded := False;
+ return;
+ end if;
+
Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size + Page_Size);
-- Since the initial signal mask of a thread is inherited from the
Adjusted_Stack_Size : size_t;
begin
+ -- Check whether both Dispatching_Domain and CPU are specified for the
+ -- task, and the CPU value is not contained within the range of
+ -- processors for the domain.
+
+ if T.Common.Domain /= null and then
+ (T.Common.Base_CPU not in T.Common.Domain'Range
+ or else not T.Common.Domain (T.Common.Base_CPU))
+ then
+ Succeeded := False;
+ return;
+ end if;
+
-- Ask for four extra bytes of stack space so that the ATCB pointer can
-- be stored below the stack limit, plus extra space for the frame of
-- Task_Wrapper. This is so the user gets the amount of stack requested
Write_Lock (Self_ID);
-- With no task hierarchy, the parent of all non-Environment tasks that
- -- are created must be the Environment task
+ -- are created must be the Environment task. Dispatching domains are
+ -- not allowed in Ravenscar, so the dispatching domain parameter will
+ -- always be null.
Initialize_ATCB
(Self_ID, State, Discriminants, Self_ID, Elaborated, Base_Priority,
- Base_CPU, Task_Info, Size, Created_Task, Success);
+ Base_CPU, null, Task_Info, Size, Created_Task, Success);
-- If we do our job right then there should never be any failures, which
-- was probably said about the Titanic; so just to be safe, let's retain
Elaborated : Access_Boolean;
Base_Priority : System.Any_Priority;
Base_CPU : System.Multiprocessors.CPU_Range;
+ Domain : Dispatching_Domain_Access;
Task_Info : System.Task_Info.Task_Info_Type;
Stack_Size : System.Parameters.Size_Type;
T : Task_Id;
T.Common.Parent := Parent;
T.Common.Base_Priority := Base_Priority;
T.Common.Base_CPU := Base_CPU;
+ T.Common.Domain := Domain;
T.Common.Current_Priority := 0;
T.Common.Protected_Action_Nesting := 0;
T.Common.Call := null;
T := STPO.New_ATCB (0);
Initialize_ATCB
(null, null, Null_Address, Null_Task, null, Base_Priority, Base_CPU,
- Task_Info.Unspecified_Task_Info, 0, T, Success);
+ null, Task_Info.Unspecified_Task_Info, 0, T, Success);
pragma Assert (Success);
STPO.Initialize (T);
Elaborated : Access_Boolean;
Base_Priority : System.Any_Priority;
Base_CPU : System.Multiprocessors.CPU_Range;
+ Domain : Dispatching_Domain_Access;
Task_Info : System.Task_Info.Task_Info_Type;
Stack_Size : System.Parameters.Size_Type;
T : Task_Id;
Task_Info : System.Task_Info.Task_Info_Type;
CPU : Integer;
Relative_Deadline : Ada.Real_Time.Time_Span;
+ Domain : Dispatching_Domain_Access;
Num_Entries : Task_Entry_Index;
Master : Master_Level;
State : Task_Procedure_Access;
end if;
Initialize_ATCB (Self_ID, State, Discriminants, P, Elaborated,
- Base_Priority, Base_CPU, Task_Info, Size, T, Success);
+ Base_Priority, Base_CPU, Domain, Task_Info, Size, T, Success);
if not Success then
Free (T);
T.Common.Task_Image_Len := Len;
end if;
- -- ??? For the moment the task inherits the dispatching domain of the
- -- parent. It will change when support for the Dispatching_Domain
- -- aspect will be added, because that will allow setting the domain
- -- in the spec of the task.
+ -- The task inherits the dispatching domain of the parent only if no
+ -- specific domain has been defined in the spec of the task (using the
+ -- dispatching domain pragma or aspect).
- if T.Common.Activator /= null then
+ if T.Common.Domain /= null then
+ null;
+ elsif T.Common.Activator /= null then
T.Common.Domain := T.Common.Activator.Common.Domain;
else
T.Common.Domain := System.Tasking.System_Domain;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
Task_Info : System.Task_Info.Task_Info_Type;
CPU : Integer;
Relative_Deadline : Ada.Real_Time.Time_Span;
+ Domain : Dispatching_Domain_Access;
Num_Entries : Task_Entry_Index;
Master : Master_Level;
State : Task_Procedure_Access;
-- before setting the affinity at run time.
-- Relative_Deadline is the relative deadline associated with the created
-- task by means of a pragma Relative_Deadline, or 0.0 if none.
+ -- Domain is the dispatching domain associated with the created task by
+ -- means of a Dispatching_Domain pragma or aspect, or null if none.
-- State is the compiler generated task's procedure body
-- Discriminants is a pointer to a limited record whose discriminants
-- are those of the task to create. This parameter should be passed as
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2011, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
System.Tasking.Initialize_ATCB
(Self_Id, null, Null_Address, Null_Task,
Foreign_Task_Elaborated'Access,
- System.Priority'First, System.Multiprocessors.Not_A_Specific_CPU,
+ System.Priority'First, System.Multiprocessors.Not_A_Specific_CPU, null,
Task_Info.Unspecified_Task_Info, 0, Self_Id, Succeeded);
Unlock_RTS;
pragma Assert (Succeeded);
end if;
-- Ada 2005 (AI-287): Limited aggregates allowed
+ -- In an instance, ignore aggregate subcomponents tnat may be limited,
+ -- because they originate in view conflicts. If the original aggregate
+ -- is legal and the actuals are legal, the aggregate itself is legal.
- if Is_Limited_Type (Typ) and then Ada_Version < Ada_2005 then
+ if Is_Limited_Type (Typ)
+ and then Ada_Version < Ada_2005
+ and then not In_Instance
+ then
Error_Msg_N ("aggregate type cannot be limited", N);
Explain_Limited_Type (Typ, N);
pragma Assert (not Delay_Required);
- when Aspect_Priority | Aspect_Interrupt_Priority => declare
- Pname : Name_Id;
+ when Aspect_Priority |
+ Aspect_Interrupt_Priority |
+ Aspect_Dispatching_Domain =>
+ declare
+ Pname : Name_Id;
+ begin
+ if A_Id = Aspect_Priority then
+ Pname := Name_Priority;
- begin
- if A_Id = Aspect_Priority then
- Pname := Name_Priority;
- else
- Pname := Name_Interrupt_Priority;
- end if;
+ elsif A_Id = Aspect_Interrupt_Priority then
+ Pname := Name_Interrupt_Priority;
- Aitem :=
- Make_Pragma (Loc,
- Pragma_Identifier =>
- Make_Identifier (Sloc (Id), Pname),
- Pragma_Argument_Associations =>
- New_List
- (Make_Pragma_Argument_Association
- (Sloc (Id), Expression => Relocate_Node (Expr))));
+ else
+ Pname := Name_Dispatching_Domain;
+ end if;
- Set_From_Aspect_Specification (Aitem, True);
+ 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))));
- pragma Assert (not Delay_Required);
- end;
+ Set_From_Aspect_Specification (Aitem, True);
+
+ pragma Assert (not Delay_Required);
+ end;
-- Aspects Pre/Post generate Precondition/Postcondition pragmas
-- with a first argument that is the expression, and a second
-- protected definition, which we need to create if it's
-- not there.
- when Aspect_Priority | Aspect_Interrupt_Priority =>
+ when Aspect_Priority |
+ Aspect_Interrupt_Priority |
+ Aspect_Dispatching_Domain =>
declare
T : Node_Id; -- the type declaration
L : List_Id; -- list of decls of task/protected
T := N;
end if;
- if Nkind (T) = N_Protected_Type_Declaration then
+ if Nkind (T) = N_Protected_Type_Declaration
+ and then A_Id /= Aspect_Dispatching_Domain
+ then
pragma Assert
(Present (Protected_Definition (T)));
End_Label => Empty));
end if;
- L := Visible_Declarations
- (Task_Definition (T));
+ L := Visible_Declarations (Task_Definition (T));
else
raise Program_Error;
when Aspect_Bit_Order =>
T := RTE (RE_Bit_Order);
+ when Aspect_Dispatching_Domain =>
+ T := RTE (RE_Dispatching_Domain);
+
when Aspect_External_Tag =>
T := Standard_String;
end if;
-- Set kind of loop parameter, which may be used in
- -- the subsequent analysis of of the condition in a
+ -- the subsequent analysis of the condition in a
-- quantified expression.
Set_Ekind (Id, E_Loop_Parameter);
end if;
end Discard_Names;
+ ------------------------
+ -- Dispatching_Domain --
+ ------------------------
+
+ -- pragma Dispatching_Domain (EXPRESSION);
+
+ when Pragma_Dispatching_Domain => Dispatching_Domain : declare
+ P : constant Node_Id := Parent (N);
+ Arg : Node_Id;
+
+ begin
+ Ada_2012_Pragma;
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+
+ -- This pragma is born obsolete, but not the aspect
+
+ if not From_Aspect_Specification (N) then
+ Check_Restriction
+ (No_Obsolescent_Features, Pragma_Identifier (N));
+ end if;
+
+ if Nkind (P) = N_Task_Definition then
+ Arg := Get_Pragma_Arg (Arg1);
+
+ -- The expression must be analyzed in the special manner
+ -- described in "Handling of Default and Per-Object
+ -- Expressions" in sem.ads.
+
+ Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
+
+ -- 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;
+
---------------
-- Elaborate --
---------------
Pragma_Default_Storage_Pool => -1,
Pragma_Dimension => -1,
Pragma_Discard_Names => 0,
+ Pragma_Dispatching_Domain => -1,
Pragma_Elaborate => -1,
Pragma_Elaborate_All => -1,
Pragma_Elaborate_Body => -1,
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
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
-- 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
-- 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 --
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
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
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 (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);
Name_uChain : constant Name_Id := N + $;
Name_uController : constant Name_Id := N + $;
Name_uCPU : constant Name_Id := N + $;
+ Name_uDispatching_Domain : constant Name_Id := N + $;
Name_uEntry_Bodies : constant Name_Id := N + $;
Name_uExpunge : constant Name_Id := N + $;
Name_uFinalizer : constant Name_Id := N + $;
Name_Detect_Blocking : constant Name_Id := N + $; -- Ada 05
Name_Default_Storage_Pool : constant Name_Id := N + $; -- Ada 12
Name_Discard_Names : constant Name_Id := N + $;
+ Name_Dispatching_Domain : constant Name_Id := N + $; -- Ada 12
Name_Elaboration_Checks : constant Name_Id := N + $; -- GNAT
Name_Eliminate : constant Name_Id := N + $; -- GNAT
Name_Extend_System : constant Name_Id := N + $; -- GNAT
Pragma_Detect_Blocking,
Pragma_Default_Storage_Pool,
Pragma_Discard_Names,
+ Pragma_Dispatching_Domain,
Pragma_Elaboration_Checks,
Pragma_Eliminate,
Pragma_Extend_System,
projects / thirdparty / gcc.git / commitdiff
