+2009-10-28 Thomas Quinot <quinot@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Type_Conversion): Perform Integer promotion for
+ the operand of the unary minus and ABS operators.
+
+ * sem_type.adb (Covers): A concurrent type and its corresponding record
+ type are compatible.
+ * exp_attr.adb (Expand_N_Attribute_Reference): Do not rewrite a 'Access
+ attribute reference for the current instance of a protected type while
+ analyzing an access discriminant constraint in a component definition.
+ Such a reference is handled in the corresponding record's init proc,
+ while initializing the constrained component.
+ * exp_ch9.adb (Expand_N_Protected_Type_Declaration): When creating the
+ corresponding record type, propagate components'
+ Has_Per_Object_Constraint flag.
+ * exp_ch3.adb (Build_Init_Procedure.Build_Init_Statements):
+ For a concurrent type, set up concurrent aspects before initializing
+ components with a per object constrain, because they may be controlled,
+ and their initialization may call entries or protected subprograms of
+ the enclosing concurrent object.
+
+2009-10-28 Emmanuel Briot <briot@adacore.com>
+
+ * prj-nmsc.adb (Add_If_Not_In_List): New subprogram, for better sharing
+ of code.
+ (Find_Source_Dirs): resolve links if Opt.Follow_Links_For_Dirs when
+ processing the directories specified explicitly in the project file.
+
2009-10-28 Robert Dewar <dewar@adacore.com>
* a-ztexio.adb, a-ztexio.ads, a-witeio.ads, a-witeio.adb,
Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
end if;
- -- If prefix is a protected type name, this is a reference to
- -- the current instance of the type.
-
- if Is_Protected_Self_Reference (Pref) then
+ -- If prefix is a protected type name, this is a reference to the
+ -- current instance of the type. For a component definition, nothing
+ -- to do (expansion will occur in the init proc). In other contexts,
+ -- rewrite into reference to current instance.
+
+ if Is_Protected_Self_Reference (Pref)
+ and then not
+ (Nkind_In (Parent (N),
+ N_Index_Or_Discriminant_Constraint,
+ N_Discriminant_Association)
+ and then
+ Nkind (Parent (Parent (Parent (Parent (N)))))
+ = N_Component_Definition)
+ then
Rewrite (Pref, Concurrent_Ref (Pref));
Analyze (Pref);
end if;
Next_Non_Pragma (Decl);
end loop;
- if Per_Object_Constraint_Components then
-
- -- Second pass: components with per-object constraints
-
- Decl := First_Non_Pragma (Component_Items (Comp_List));
- while Present (Decl) loop
- Loc := Sloc (Decl);
- Id := Defining_Identifier (Decl);
- Typ := Etype (Id);
-
- if Has_Access_Constraint (Id)
- and then No (Expression (Decl))
- then
- if Has_Non_Null_Base_Init_Proc (Typ) then
- Append_List_To (Statement_List,
- Build_Initialization_Call (Loc,
- Make_Selected_Component (Loc,
- Prefix => Make_Identifier (Loc, Name_uInit),
- Selector_Name => New_Occurrence_Of (Id, Loc)),
- Typ,
- In_Init_Proc => True,
- Enclos_Type => Rec_Type,
- Discr_Map => Discr_Map));
-
- Clean_Task_Names (Typ, Proc_Id);
-
- elsif Component_Needs_Simple_Initialization (Typ) then
- Append_List_To (Statement_List,
- Build_Assignment
- (Id, Get_Simple_Init_Val (Typ, N, Esize (Id))));
- end if;
- end if;
-
- Next_Non_Pragma (Decl);
- end loop;
- end if;
-
- -- Process the variant part
-
- if Present (Variant_Part (Comp_List)) then
- Alt_List := New_List;
- Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
- while Present (Variant) loop
- Loc := Sloc (Variant);
- Append_To (Alt_List,
- Make_Case_Statement_Alternative (Loc,
- Discrete_Choices =>
- New_Copy_List (Discrete_Choices (Variant)),
- Statements =>
- Build_Init_Statements (Component_List (Variant))));
- Next_Non_Pragma (Variant);
- end loop;
-
- -- The expression of the case statement which is a reference
- -- to one of the discriminants is replaced by the appropriate
- -- formal parameter of the initialization procedure.
-
- Append_To (Statement_List,
- Make_Case_Statement (Loc,
- Expression =>
- New_Reference_To (Discriminal (
- Entity (Name (Variant_Part (Comp_List)))), Loc),
- Alternatives => Alt_List));
- end if;
+ -- Set up tasks and protected object support. This needs to be done
+ -- before any component with a per-object access discriminant
+ -- constraint, or any variant part (which may contain such
+ -- components) is initialized, because the initialization of these
+ -- components may reference the enclosing concurrent object.
-- For a task record type, add the task create call and calls
-- to bind any interrupt (signal) entries.
end if;
end if;
+ if Per_Object_Constraint_Components then
+
+ -- Second pass: components with per-object constraints
+
+ Decl := First_Non_Pragma (Component_Items (Comp_List));
+ while Present (Decl) loop
+ Loc := Sloc (Decl);
+ Id := Defining_Identifier (Decl);
+ Typ := Etype (Id);
+
+ if Has_Access_Constraint (Id)
+ and then No (Expression (Decl))
+ then
+ if Has_Non_Null_Base_Init_Proc (Typ) then
+ Append_List_To (Statement_List,
+ Build_Initialization_Call (Loc,
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Selector_Name => New_Occurrence_Of (Id, Loc)),
+ Typ,
+ In_Init_Proc => True,
+ Enclos_Type => Rec_Type,
+ Discr_Map => Discr_Map));
+
+ Clean_Task_Names (Typ, Proc_Id);
+
+ elsif Component_Needs_Simple_Initialization (Typ) then
+ Append_List_To (Statement_List,
+ Build_Assignment
+ (Id, Get_Simple_Init_Val (Typ, N, Esize (Id))));
+ end if;
+ end if;
+
+ Next_Non_Pragma (Decl);
+ end loop;
+ end if;
+
+ -- Process the variant part
+
+ if Present (Variant_Part (Comp_List)) then
+ Alt_List := New_List;
+ Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
+ while Present (Variant) loop
+ Loc := Sloc (Variant);
+ Append_To (Alt_List,
+ Make_Case_Statement_Alternative (Loc,
+ Discrete_Choices =>
+ New_Copy_List (Discrete_Choices (Variant)),
+ Statements =>
+ Build_Init_Statements (Component_List (Variant))));
+ Next_Non_Pragma (Variant);
+ end loop;
+
+ -- The expression of the case statement which is a reference
+ -- to one of the discriminants is replaced by the appropriate
+ -- formal parameter of the initialization procedure.
+
+ Append_To (Statement_List,
+ Make_Case_Statement (Loc,
+ Expression =>
+ New_Reference_To (Discriminal (
+ Entity (Name (Variant_Part (Comp_List)))), Loc),
+ Alternatives => Alt_List));
+ end if;
+
-- If no initializations when generated for component declarations
-- corresponding to this Statement_List, append a null statement
-- to the Statement_List to make it a valid Ada tree.
Subtype_Mark => New_Reference_To (Standard_Integer, Loc),
Expression => Relocate_Node (Right_Opnd (Operand)));
- if Nkind (Operand) = N_Op_Minus then
- Opnd := Make_Op_Minus (Loc, Right_Opnd => R);
+ Opnd := New_Op_Node (Nkind (Operand), Loc);
+ Set_Right_Opnd (Opnd, R);
- else
+ if Nkind (Operand) in N_Binary_Op then
L :=
Make_Type_Conversion (Loc,
Subtype_Mark => New_Reference_To (Standard_Integer, Loc),
Expression => Relocate_Node (Left_Opnd (Operand)));
- Opnd := New_Op_Node (Nkind (Operand), Loc);
- Set_Left_Opnd (Opnd, L);
- Set_Right_Opnd (Opnd, R);
+ Set_Left_Opnd (Opnd, L);
+ end if;
- Rewrite (N,
- Make_Type_Conversion (Loc,
- Subtype_Mark => Relocate_Node (Subtype_Mark (N)),
- Expression => Opnd));
+ Rewrite (N,
+ Make_Type_Conversion (Loc,
+ Subtype_Mark => Relocate_Node (Subtype_Mark (N)),
+ Expression => Opnd));
- Analyze_And_Resolve (N, Target_Type);
- return;
- end if;
+ Analyze_And_Resolve (N, Target_Type);
+ return;
end;
end if;
Root_Operand_Type = Base_Type (Standard_Short_Short_Integer))
-- Test for interesting operation, which includes addition,
- -- division, exponentiation, multiplication, subtraction, and
- -- unary negation.
+ -- division, exponentiation, multiplication, subtraction, absolute
+ -- value and unary negation. Unary "+" is omitted since it is a
+ -- no-op and thus can't overflow.
- and then Nkind_In (Operand, N_Op_Add,
+ and then Nkind_In (Operand, N_Op_Abs,
+ N_Op_Add,
N_Op_Divide,
N_Op_Expon,
N_Op_Minus,
declare
Old_Comp : constant Node_Id := Component_Definition (Priv);
- Pent : constant Entity_Id := Defining_Identifier (Priv);
+ Oent : constant Entity_Id := Defining_Identifier (Priv);
New_Comp : Node_Id;
+ Nent : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Sloc (Oent), Chars (Oent));
begin
if Present (Subtype_Indication (Old_Comp)) then
New_Comp :=
- Make_Component_Definition (Sloc (Pent),
+ Make_Component_Definition (Sloc (Oent),
Aliased_Present => False,
Subtype_Indication =>
New_Copy_Tree (Subtype_Indication (Old_Comp),
Discr_Map));
else
New_Comp :=
- Make_Component_Definition (Sloc (Pent),
+ Make_Component_Definition (Sloc (Oent),
Aliased_Present => False,
Access_Definition =>
New_Copy_Tree (Access_Definition (Old_Comp),
New_Priv :=
Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Sloc (Pent), Chars (Pent)),
+ Defining_Identifier => Nent,
Component_Definition => New_Comp,
Expression => Expression (Priv));
+ Set_Has_Per_Object_Constraint (Nent,
+ Has_Per_Object_Constraint (Oent));
+
Append_To (Cdecls, New_Priv);
end;
Removed : Boolean := False)
is
Directory : constant String := Get_Name_String (From);
- Element : String_Element;
+
+ procedure Add_If_Not_In_List
+ (Path_Id : Name_Id;
+ Display_Path_Id : Name_Id);
+ -- Add the directory Path_Id to the list of source_dirs if not
+ -- already in the list
procedure Recursive_Find_Dirs (Path : Name_Id);
-- Find all the subdirectories (recursively) of Path and add them
-- to the list of source directories of the project.
- -------------------------
- -- Recursive_Find_Dirs --
- -------------------------
-
- procedure Recursive_Find_Dirs (Path : Name_Id) is
- Dir : Dir_Type;
- Name : String (1 .. 250);
- Last : Natural;
- List : String_List_Id;
- Prev : String_List_Id;
- Rank_List : Number_List_Index;
- Prev_Rank : Number_List_Index;
- Element : String_Element;
- Found : Boolean := False;
-
- Non_Canonical_Path : Name_Id := No_Name;
- Canonical_Path : Name_Id := No_Name;
-
- The_Path : constant String :=
- Normalize_Pathname
- (Get_Name_String (Path),
- Directory =>
- Get_Name_String (Project.Directory.Display_Name),
- Resolve_Links => Opt.Follow_Links_For_Dirs) &
- Directory_Separator;
-
- The_Path_Last : constant Natural :=
- Compute_Directory_Last (The_Path);
-
+ ------------------------
+ -- Add_If_Not_In_List --
+ ------------------------
+
+ procedure Add_If_Not_In_List
+ (Path_Id : Name_Id;
+ Display_Path_Id : Name_Id)
+ is
+ List : String_List_Id;
+ Prev : String_List_Id;
+ Rank_List : Number_List_Index;
+ Prev_Rank : Number_List_Index;
+ Element : String_Element;
begin
- Name_Len := The_Path_Last - The_Path'First + 1;
- Name_Buffer (1 .. Name_Len) :=
- The_Path (The_Path'First .. The_Path_Last);
- Non_Canonical_Path := Name_Find;
- Canonical_Path :=
- Name_Id (Canonical_Case_File_Name (Non_Canonical_Path));
-
- -- To avoid processing the same directory several times, check
- -- if the directory is already in Recursive_Dirs. If it is, then
- -- there is nothing to do, just return. If it is not, put it there
- -- and continue recursive processing.
-
- if not Removed then
- if Recursive_Dirs.Get (Visited, Canonical_Path) then
- return;
- else
- Recursive_Dirs.Set (Visited, Canonical_Path, True);
- end if;
- end if;
-
- -- Check if directory is already in list
-
- List := Project.Source_Dirs;
- Prev := Nil_String;
- Rank_List := Project.Source_Dir_Ranks;
+ Prev := Nil_String;
Prev_Rank := No_Number_List;
+ List := Project.Source_Dirs;
+ Rank_List := Project.Source_Dir_Ranks;
+
while List /= Nil_String loop
Element := Data.Tree.String_Elements.Table (List);
-
- if Element.Value /= No_Name then
- Found := Element.Value = Canonical_Path;
- exit when Found;
- end if;
-
+ exit when Element.Value = Path_Id;
Prev := List;
List := Element.Next;
Prev_Rank := Rank_List;
- Rank_List := Data.Tree.Number_Lists.Table (Rank_List).Next;
+ Rank_List := Data.Tree.Number_Lists.Table (Prev_Rank).Next;
end loop;
- -- If directory is not already in list, put it there
+ -- The directory is in the list if List is not Nil_String
- if (not Removed) and (not Found) then
+ if not Removed and then List = Nil_String then
if Current_Verbosity = High then
- Write_Str (" ");
- Write_Line (The_Path (The_Path'First .. The_Path_Last));
+ Write_Str (" Adding Source Dir=");
+ Write_Line (Get_Name_String (Path_Id));
end if;
String_Element_Table.Increment_Last (Data.Tree.String_Elements);
Element :=
- (Value => Canonical_Path,
- Display_Value => Non_Canonical_Path,
+ (Value => Path_Id,
+ Index => 0,
+ Display_Value => Display_Path_Id,
Location => No_Location,
Flag => False,
- Next => Nil_String,
- Index => 0);
+ Next => Nil_String);
Number_List_Table.Increment_Last (Data.Tree.Number_Lists);
- -- Case of first source directory
-
if Last_Source_Dir = Nil_String then
+
+ -- This is the first source directory
+
Project.Source_Dirs :=
String_Element_Table.Last (Data.Tree.String_Elements);
Project.Source_Dir_Ranks :=
Number_List_Table.Last (Data.Tree.Number_Lists);
- -- Here we already have source directories
-
else
- -- Link the previous last to the new one
+ -- We already have source directories, link the previous
+ -- last to the new one.
- Data.Tree.String_Elements.Table
- (Last_Source_Dir).Next :=
+ Data.Tree.String_Elements.Table (Last_Source_Dir).Next :=
String_Element_Table.Last (Data.Tree.String_Elements);
- Data.Tree.Number_Lists.Table
- (Last_Src_Dir_Rank).Next :=
+ Data.Tree.Number_Lists.Table (Last_Src_Dir_Rank).Next :=
Number_List_Table.Last (Data.Tree.Number_Lists);
end if;
Data.Tree.Number_Lists.Table (Last_Src_Dir_Rank) :=
(Number => Rank, Next => No_Number_List);
- elsif Removed and Found then
+ elsif List /= Nil_String then
+ -- Remove source dir, if present
+
if Prev = Nil_String then
Project.Source_Dirs :=
Data.Tree.String_Elements.Table (List).Next;
Project.Source_Dir_Ranks :=
Data.Tree.Number_Lists.Table (Rank_List).Next;
+
else
Data.Tree.String_Elements.Table (Prev).Next :=
Data.Tree.String_Elements.Table (List).Next;
Data.Tree.Number_Lists.Table (Rank_List).Next;
end if;
end if;
+ end Add_If_Not_In_List;
+
+ -------------------------
+ -- Recursive_Find_Dirs --
+ -------------------------
+
+ procedure Recursive_Find_Dirs (Path : Name_Id) is
+ Dir : Dir_Type;
+ Name : String (1 .. 250);
+ Last : Natural;
+ Non_Canonical_Path : Name_Id := No_Name;
+ Canonical_Path : Name_Id := No_Name;
+
+ The_Path : constant String :=
+ Normalize_Pathname
+ (Get_Name_String (Path),
+ Directory =>
+ Get_Name_String (Project.Directory.Display_Name),
+ Resolve_Links => Opt.Follow_Links_For_Dirs) &
+ Directory_Separator;
+
+ The_Path_Last : constant Natural :=
+ Compute_Directory_Last (The_Path);
+
+ begin
+ Name_Len := The_Path_Last - The_Path'First + 1;
+ Name_Buffer (1 .. Name_Len) :=
+ The_Path (The_Path'First .. The_Path_Last);
+ Non_Canonical_Path := Name_Find;
+ Canonical_Path :=
+ Name_Id (Canonical_Case_File_Name (Non_Canonical_Path));
+
+ -- To avoid processing the same directory several times, check
+ -- if the directory is already in Recursive_Dirs. If it is, then
+ -- there is nothing to do, just return. If it is not, put it there
+ -- and continue recursive processing.
+
+ if not Removed then
+ if Recursive_Dirs.Get (Visited, Canonical_Path) then
+ return;
+ else
+ Recursive_Dirs.Set (Visited, Canonical_Path, True);
+ end if;
+ end if;
+
+ Add_If_Not_In_List
+ (Path_Id => Canonical_Path,
+ Display_Path_Id => Non_Canonical_Path);
-- Now look for subdirectories. We do that even when this
-- directory is already in the list, because some of its
Directory =>
Get_Name_String
(Project.Directory.Display_Name),
- Resolve_Links => False,
+ Resolve_Links =>
+ Opt.Follow_Links_For_Dirs,
Case_Sensitive => True);
begin
else
declare
Path_Name : Path_Information;
- List : String_List_Id;
- Prev : String_List_Id;
- Rank_List : Number_List_Index;
- Prev_Rank : Number_List_Index;
Dir_Exists : Boolean;
begin
else
declare
Path : constant String :=
- Get_Name_String (Path_Name.Name);
+ Normalize_Pathname
+ (Name => Get_Name_String (Path_Name.Name),
+ Directory =>
+ Get_Name_String (Project.Directory.Name),
+ Resolve_Links => Opt.Follow_Links_For_Dirs,
+ Case_Sensitive => True);
+
Last_Path : constant Natural :=
Compute_Directory_Last (Path);
Path_Id : Name_Id;
Name_Len := 0;
Add_Str_To_Name_Buffer (Path (Path'First .. Last_Path));
Path_Id := Name_Find;
+
Name_Len := 0;
Add_Str_To_Name_Buffer
(Display_Path
(Display_Path'First .. Last_Display_Path));
Display_Path_Id := Name_Find;
- -- Check if the directory is already in the list
-
- Prev := Nil_String;
- Prev_Rank := No_Number_List;
-
- -- Look for source dir in current list
-
- List := Project.Source_Dirs;
- Rank_List := Project.Source_Dir_Ranks;
- while List /= Nil_String loop
- Element := Data.Tree.String_Elements.Table (List);
- exit when Element.Value = Path_Id;
- Prev := List;
- List := Element.Next;
- Prev_Rank := Rank_List;
- Rank_List :=
- Data.Tree.Number_Lists.Table (Prev_Rank).Next;
- end loop;
-
- -- The directory is in the list if List is not Nil_String
-
- if not Removed then
-
- -- As it is an existing directory, we add it to the
- -- list of directories, if not already in the list.
-
- if List = Nil_String then
- String_Element_Table.Increment_Last
- (Data.Tree.String_Elements);
- Element :=
- (Value => Path_Id,
- Index => 0,
- Display_Value => Display_Path_Id,
- Location => No_Location,
- Flag => False,
- Next => Nil_String);
- Number_List_Table.Increment_Last
- (Data.Tree.Number_Lists);
-
- if Last_Source_Dir = Nil_String then
-
- -- This is the first source directory
-
- Project.Source_Dirs :=
- String_Element_Table.Last
- (Data.Tree.String_Elements);
- Project.Source_Dir_Ranks :=
- Number_List_Table.Last
- (Data.Tree.Number_Lists);
-
- else
- -- We already have source directories, link the
- -- previous last to the new one.
-
- Data.Tree.String_Elements.Table
- (Last_Source_Dir).Next :=
- String_Element_Table.Last
- (Data.Tree.String_Elements);
- Data.Tree.Number_Lists.Table
- (Last_Src_Dir_Rank).Next :=
- Number_List_Table.Last
- (Data.Tree.Number_Lists);
-
- end if;
-
- -- And register this source directory as the new
- -- last.
-
- Last_Source_Dir :=
- String_Element_Table.Last
- (Data.Tree.String_Elements);
- Data.Tree.String_Elements.Table
- (Last_Source_Dir) := Element;
- Last_Src_Dir_Rank :=
- Number_List_Table.Last
- (Data.Tree.Number_Lists);
- Data.Tree.Number_Lists.Table
- (Last_Src_Dir_Rank) :=
- (Number => Rank, Next => No_Number_List);
- end if;
-
- else
- -- Remove source dir, if present
-
- if List /= Nil_String then
- -- Source dir was found, remove it from the list
-
- if Prev = Nil_String then
- Project.Source_Dirs :=
- Data.Tree.String_Elements.Table (List).Next;
- Project.Source_Dir_Ranks :=
- Data.Tree.Number_Lists.Table (Rank_List).Next;
-
- else
- Data.Tree.String_Elements.Table (Prev).Next :=
- Data.Tree.String_Elements.Table (List).Next;
- Data.Tree.Number_Lists.Table (Prev_Rank).Next :=
- Data.Tree.Number_Lists.Table (Rank_List).Next;
- end if;
- end if;
- end if;
+ Add_If_Not_In_List
+ (Path_Id => Path_Id,
+ Display_Path_Id => Display_Path_Id);
end;
end if;
end;
or else Scope (T1) /= Scope (T2));
end if;
- -- Literals are compatible with types in a given "class"
+ -- Literals are compatible with types in a given "class"
elsif (T2 = Universal_Integer and then Is_Integer_Type (T1))
or else (T2 = Universal_Real and then Is_Real_Type (T1))
then
return Covers (Corresponding_Remote_Type (T2), T1);
+ elsif Is_Record_Type (T1) and then Is_Concurrent_Type (T2) then
+ return Covers (T1, Corresponding_Record_Type (T2));
+
+ elsif Is_Concurrent_Type (T1) and then Is_Record_Type (T2) then
+ return Covers (Corresponding_Record_Type (T1), T2);
+
elsif Ekind (T2) = E_Access_Attribute_Type
and then (Ekind (BT1) = E_General_Access_Type
or else Ekind (BT1) = E_Access_Type)
OSDN Git Service
