2011-08-31 Jose Ruiz <ruiz@adacore.com>
+ * s-taprop-vxworks.adb, s-taprop-mingw.adb, s-taprop-linux.adb,
+ s-taprop-solaris.adb (Create_Task): Not_A_Specific_CPU can be assigned
+ to any dispatching domain.
+
+2011-08-31 Thomas Quinot <quinot@adacore.com>
+
+ * exp_ch4.adb: Minor reformatting.
+
+2011-08-31 Bob Duff <duff@adacore.com>
+
+ * sem_ch6.adb (Get_Generic_Parent_Type): Don't query Subtype_Indication
+ on nodes for which it is not defined.
+ (Is_Non_Overriding_Operation): Exit the loop when we find a generic
+ parent type.
+
+2011-08-31 Bob Duff <duff@adacore.com>
+
+ * sem_ch3.adb (Process_Full_View): Disable legality check if
+ In_Instance, to avoid spurious errors.
+ * sem_ch12.adb (Validate_Derived_Type_Instance): Disable legality check
+ if In_Instance, to avoid spurious errors.
+
+2011-08-31 Pascal Obry <obry@adacore.com>
+
+ * a-direct.adb: Use Dir_Seps everywhere to properly handle all
+ directory speparators.
+ (Compose): Use Dir_Seps to handle both forms.
+ (Create_Path): Use Dir_Seps instead of explicit check, no semantic
+ changes.
+ (Extension): Use Dir_Seps to handle both forms.
+
+2011-08-31 Pascal Obry <obry@adacore.com>
+
+ * prj-conf.adb: Minor reformatting.
+
+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
with Ada.Calendar; use Ada.Calendar;
with Ada.Calendar.Formatting; use Ada.Calendar.Formatting;
with Ada.Directories.Validity; use Ada.Directories.Validity;
-with Ada.Strings.Maps;
+with Ada.Strings.Maps; use Ada; use Ada.Strings.Maps;
with Ada.Strings.Fixed;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Unchecked_Conversion;
pragma Import (C, Dir_Separator, "__gnat_dir_separator");
-- Running system default directory separator
- Dir_Seps : constant Ada.Strings.Maps.Character_Set :=
- Ada.Strings.Maps.To_Set ("/\");
+ Dir_Seps : constant Character_Set := Strings.Maps.To_Set ("/\");
-- UNIX and DOS style directory separators
Max_Path : Integer;
-- Add a directory separator if needed
- if Last /= 0 and then Result (Last) /= Dir_Separator then
+ if Last /= 0 and then not Is_In (Result (Last), Dir_Seps) then
Last := Last + 1;
Result (Last) := Dir_Separator;
end if;
-- Look for the end of an intermediate directory
- if New_Dir (J) /= Dir_Separator and then
- New_Dir (J) /= '/'
- then
+ if not Is_In (New_Dir (J), Dir_Seps) then
Last := J;
-- We have found a new intermediate directory each time we find
-- a first directory separator.
- elsif New_Dir (J - 1) /= Dir_Separator and then
- New_Dir (J - 1) /= '/'
- then
+ elsif not Is_In (New_Dir (J - 1), Dir_Seps) then
-- No need to create the directory if it already exists
-- If a directory separator is found before a dot, there is no
-- extension.
- if Name (Pos) = Dir_Separator then
+ if Is_In (Name (Pos), Dir_Seps) then
return Empty_String;
elsif Name (Pos) = '.' then
-- Insert explicit dereference if required
if Is_Access_Type (Ptyp) then
- Set_Etype (P, Ptyp); -- in case it's private
+
+ -- First set prefix type to proper access type, in case it currently
+ -- has a private (non-access) view of this type.
+
+ Set_Etype (P, Ptyp);
+
Insert_Explicit_Dereference (P);
Analyze_And_Resolve (P, Designated_Type (Ptyp));
-- configuration list.
declare
- Conf_List : String_List_Id := Conf_Attr.Value.Values;
- Conf_Elem : String_Element;
User_List : constant String_List_Id :=
User_Attr.Value.Values;
- New_List : String_List_Id;
- New_Elem : String_Element;
+ Conf_List : String_List_Id := Conf_Attr.Value.Values;
+ Conf_Elem : String_Element;
+ New_List : String_List_Id;
+ New_Elem : String_Element;
begin
-- Create new list
if Proj.Project.Qualifier = Aggregate then
declare
List : Aggregated_Project_List :=
- Proj.Project.Aggregated_Projects;
+ Proj.Project.Aggregated_Projects;
begin
while List /= null loop
Debug_Output
------------------
function Check_Target
- (Config_File : Project_Id;
+ (Config_File : Project_Id;
Autoconf_Specified : Boolean;
- Project_Tree : Prj.Project_Tree_Ref;
- Target : String := "") return Boolean
+ Project_Tree : Prj.Project_Tree_Ref;
+ Target : String := "") return Boolean
is
- Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared;
+ Shared : constant Shared_Project_Tree_Data_Access :=
+ Project_Tree.Shared;
Variable : constant Variable_Value :=
Value_Of
(Name_Target, Config_File.Decl.Attributes, Shared);
-------------------------
function Get_Config_Switches return Argument_List_Access is
+
package Language_Htable is new GNAT.HTable.Simple_HTable
(Header_Num => Prj.Header_Num,
Element => Name_Id,
-- Add all --config switches for this project. This is also called
-- for aggregate projects.
+ -------------------------------------
+ -- Add_Config_Switches_For_Project --
+ -------------------------------------
+
procedure Add_Config_Switches_For_Project
(Project : Project_Id;
Tree : Project_Tree_Ref;
begin
For_Every_Imported_Project
- (By => Project,
- Tree => Project_Tree,
- With_State => Dummy,
+ (By => Project,
+ Tree => Project_Tree,
+ With_State => Dummy,
Include_Aggregated => True);
Name := Language_Htable.Get_First;
declare
Config_Command : constant String :=
- "--config=" & Get_Name_String (Name);
+ "--config=" & Get_Name_String (Name);
Runtime_Name : constant String :=
- Runtime_Name_For (Name);
+ Runtime_Name_For (Name);
begin
if Variable = Nil_Variable_Value
declare
Compiler_Command : constant String :=
- Get_Name_String (Variable.Value);
+ Get_Name_String (Variable.Value);
begin
if Is_Absolute_Path (Compiler_Command) then
end if;
if Config_File_Path = null then
- if (not Allow_Automatic_Generation) and then
- Config_File_Name /= ""
+ if (not Allow_Automatic_Generation)
+ and then Config_File_Name /= ""
then
Raise_Invalid_Config
("could not locate main configuration project "
Prj.Initialize (Project_Tree);
- Main_Project := No_Project;
+ Main_Project := No_Project;
Automatically_Generated := False;
Prj.Part.Parse
- (In_Tree => Project_Node_Tree,
- Project => User_Project_Node,
- Project_File_Name => Project_File_Name,
- Errout_Handling => Prj.Part.Finalize_If_Error,
- Packages_To_Check => Packages_To_Check,
- Current_Directory => Current_Directory,
- Is_Config_File => False,
- Env => Env);
+ (In_Tree => Project_Node_Tree,
+ Project => User_Project_Node,
+ Project_File_Name => Project_File_Name,
+ Errout_Handling => Prj.Part.Finalize_If_Error,
+ Packages_To_Check => Packages_To_Check,
+ Current_Directory => Current_Directory,
+ Is_Config_File => False,
+ Env => Env);
if User_Project_Node = Empty_Node then
User_Project_Node := Empty_Node;
On_Load_Config : Config_File_Hook := null;
Reset_Tree : Boolean := True)
is
- Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared;
+ Shared : constant Shared_Project_Tree_Data_Access :=
+ Project_Tree.Shared;
Main_Config_Project : Project_Id;
- Success : Boolean;
+ Success : Boolean;
begin
Main_Project := No_Project;
if not Is_Absolute_Path (Project_Tree.Source_Info_File_Name.all) then
declare
Obj_Dir : constant Variable_Value :=
- Value_Of
- (Name_Object_Dir,
- Main_Project.Decl.Attributes,
- Shared);
+ Value_Of
+ (Name_Object_Dir,
+ Main_Project.Decl.Attributes,
+ Shared);
begin
if Obj_Dir = Nil_Variable_Value or else Obj_Dir.Default then
-- Finish processing the user's project
Prj.Proc.Process_Project_Tree_Phase_2
- (In_Tree => Project_Tree,
- Project => Main_Project,
- Success => Success,
- From_Project_Node => User_Project_Node,
- From_Project_Node_Tree => Project_Node_Tree,
- Env => Env);
+ (In_Tree => Project_Tree,
+ Project => Main_Project,
+ Success => Success,
+ From_Project_Node => User_Project_Node,
+ From_Project_Node_Tree => Project_Node_Tree,
+ Env => Env);
if Success then
- if Project_Tree.Source_Info_File_Name /= null and then
- not Project_Tree.Source_Info_File_Exists
+ if Project_Tree.Source_Info_File_Name /= null
+ and then not Project_Tree.Source_Info_File_Exists
then
Write_Source_Info_File (Project_Tree);
end if;
-- processors for the domain.
if T.Common.Domain /= null and then
+ T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU and then
(T.Common.Base_CPU not in T.Common.Domain'Range
or else not T.Common.Domain (T.Common.Base_CPU))
then
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 /= System.Multiprocessors.Not_A_Specific_CPU and then
(T.Common.Base_CPU not in T.Common.Domain'Range
or else not T.Common.Domain (T.Common.Base_CPU))
then
-- actual use.
use System.Task_Info;
+ use type System.Multiprocessors.CPU_Range;
begin
-- Check whether both Dispatching_Domain and CPU are specified for the
-- processors for the domain.
if T.Common.Domain /= null and then
+ T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU and then
(T.Common.Base_CPU not in T.Common.Domain'Range
or else not T.Common.Domain (T.Common.Base_CPU))
then
is
Adjusted_Stack_Size : size_t;
+ 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 /= System.Multiprocessors.Not_A_Specific_CPU and then
(T.Common.Base_CPU not in T.Common.Domain'Range
or else not T.Common.Domain (T.Common.Base_CPU))
then
and then not Is_Limited_Type (A_Gen_T)
and then Ada_Version >= Ada_2012
then
- Error_Msg_NE
- ("actual for non-limited & cannot be a limited type", Actual,
- Gen_T);
- Explain_Limited_Type (Act_T, Actual);
- Abandon_Instantiation (Actual);
+ if In_Instance then
+ null;
+ else
+ Error_Msg_NE
+ ("actual for non-limited & cannot be a limited type", Actual,
+ Gen_T);
+ Explain_Limited_Type (Act_T, Actual);
+ Abandon_Instantiation (Actual);
+ end if;
end if;
end Validate_Derived_Type_Instance;
if Is_Limited_Type (Act_T)
and then not Is_Limited_Type (A_Gen_T)
then
- Error_Msg_NE
- ("actual for non-limited & cannot be a limited type", Actual,
- Gen_T);
- Explain_Limited_Type (Act_T, Actual);
- Abandon_Instantiation (Actual);
+ if In_Instance then
+ null;
+ else
+ Error_Msg_NE
+ ("actual for non-limited & cannot be a limited type", Actual,
+ Gen_T);
+ Explain_Limited_Type (Act_T, Actual);
+ Abandon_Instantiation (Actual);
+ end if;
elsif Known_To_Have_Preelab_Init (A_Gen_T)
and then not Has_Preelaborable_Initialization (Act_T)
-- 2. Those generated by the Expression
- -- 3. Those used to constrained the Object Definition with the
- -- expression constraints when it is unconstrained
+ -- 3. Those used to constrain the Object Definition with the
+ -- expression constraints when the definition is unconstrained
-- They must be generated in this order to avoid order of elaboration
-- issues. Thus the first step (after entering the name) is to analyze
and then (Is_Limited_Type (Full_T)
or else Is_Limited_Composite (Full_T))
then
- Error_Msg_N
- ("completion of nonlimited type cannot be limited", Full_T);
- Explain_Limited_Type (Full_T, Full_T);
+ if In_Instance then
+ null;
+ else
+ Error_Msg_N
+ ("completion of nonlimited type cannot be limited", Full_T);
+ Explain_Limited_Type (Full_T, Full_T);
+ end if;
elsif Is_Abstract_Type (Full_T)
and then not Is_Abstract_Type (Priv_T)
function Get_Generic_Parent_Type (F_Typ : Entity_Id) return Entity_Id is
G_Typ : Entity_Id;
+ Defn : Node_Id;
Indic : Node_Id;
begin
-- is needed for cases where a full derived type has been
-- rewritten.)
- Indic := Subtype_Indication
- (Type_Definition (Original_Node (Parent (F_Typ))));
+ Defn := Type_Definition (Original_Node (Parent (F_Typ)));
+ if Nkind (Defn) = N_Derived_Type_Definition then
+ Indic := Subtype_Indication (Defn);
- if Nkind (Indic) = N_Subtype_Indication then
- G_Typ := Entity (Subtype_Mark (Indic));
- else
- G_Typ := Entity (Indic);
- end if;
+ if Nkind (Indic) = N_Subtype_Indication then
+ G_Typ := Entity (Subtype_Mark (Indic));
+ else
+ G_Typ := Entity (Indic);
+ end if;
- if Nkind (Parent (G_Typ)) = N_Subtype_Declaration
- and then Present (Generic_Parent_Type (Parent (G_Typ)))
- then
- return Generic_Parent_Type (Parent (G_Typ));
+ if Nkind (Parent (G_Typ)) = N_Subtype_Declaration
+ and then Present (Generic_Parent_Type (Parent (G_Typ)))
+ then
+ return Generic_Parent_Type (Parent (G_Typ));
+ end if;
end if;
end if;
and then In_Private_Part (Current_Scope)
and then Comes_From_Source (New_E)
then
- -- We examine the formals and result subtype of the inherited
- -- operation, to determine whether their type is derived from (the
- -- instance of) a generic type.
+ -- We examine the formals and result type of the inherited operation,
+ -- to determine whether their type is derived from (the instance of)
+ -- a generic type. The first such formal or result type is the one
+ -- tested.
Formal := First_Formal (Prev_E);
while Present (Formal) loop
end if;
G_Typ := Get_Generic_Parent_Type (F_Typ);
+ exit when Present (G_Typ);
Next_Formal (Formal);
end loop;
OSDN Git Service
