diff options
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/ChangeLog | 28 | ||||
| -rw-r--r-- | gcc/ada/exp_attr.adb | 18 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 134 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 32 | ||||
| -rw-r--r-- | gcc/ada/exp_ch9.adb | 15 | ||||
| -rw-r--r-- | gcc/ada/prj-nmsc.adb | 292 | ||||
| -rw-r--r-- | gcc/ada/sem_type.adb | 8 |
7 files changed, 250 insertions, 277 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b7e7448..7cc30bb 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,31 @@ +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, diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index d5cce9b..67babec 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -654,10 +654,20 @@ package body Exp_Attr is 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; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 414e567..9a91e2a 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -2733,70 +2733,11 @@ package body Exp_Ch3 is 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. @@ -2898,6 +2839,71 @@ package body Exp_Ch3 is 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. diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index c98e982..6a7ea4f 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -8056,27 +8056,25 @@ package body Exp_Ch4 is 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; @@ -9174,10 +9172,12 @@ package body Exp_Ch4 is 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, diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index db22726..2079052 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -7821,20 +7821,23 @@ package body Exp_Ch9 is 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), @@ -7843,11 +7846,13 @@ package body Exp_Ch9 is 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; diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index cec5e6b..064cbb6 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -4707,119 +4707,80 @@ package body Prj.Nmsc is 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; @@ -4834,12 +4795,15 @@ package body Prj.Nmsc is 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; @@ -4847,6 +4811,54 @@ package body Prj.Nmsc is 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 @@ -4945,7 +4957,8 @@ package body Prj.Nmsc is Directory => Get_Name_String (Project.Directory.Display_Name), - Resolve_Links => False, + Resolve_Links => + Opt.Follow_Links_For_Dirs, Case_Sensitive => True); begin @@ -4987,10 +5000,6 @@ package body Prj.Nmsc is 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 @@ -5020,7 +5029,13 @@ package body Prj.Nmsc is 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; @@ -5036,113 +5051,16 @@ package body Prj.Nmsc is 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; diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 931112c..6f3e369 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -791,7 +791,7 @@ package body Sem_Type is 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)) @@ -970,6 +970,12 @@ package body Sem_Type is 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) |