diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 31 | ||||
| -rw-r--r-- | gcc/ada/init.c | 6 | ||||
| -rw-r--r-- | gcc/ada/make.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/prj-nmsc.adb | 286 | ||||
| -rw-r--r-- | gcc/ada/sem_ch8.adb | 79 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/sem_type.adb | 40 |
7 files changed, 260 insertions, 189 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5617544758e..4400d98ce26 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,34 @@ +2009-04-15 Ed Schonberg <schonberg@adacore.com> + + * sem_ch8.adb (Use_One_Type): If both clauses appear on the same unit, + the second is redundant, regardless of scopes. + +2009-04-15 Vincent Celier <celier@adacore.com> + + * prj-nmsc.adb (Get_Directories): Check for sources before checking + the object directory as when there are no sources, they may not be any + object directory. + + * make.adb (Gnatmake): Do not attempt to get the path name of the exec + directory, when there are no exec directory. + +2009-04-15 Ed Schonberg <schonberg@adacore.com> + + * sem_type.adb (Remove_Conversions): In order to resolve spurious + ambiguities, refine removal of universal interpretations from complex + expressions with literal arguments, when some numeric operators have + been declared abstract. + +2009-04-15 Ed Falis <falis@adacore.com> + + * init.c: Map SIGSEGV to Storage_Error for all targets for uniformity + and backward compatibility for targets using probing for stack overflow + +2009-04-15 Ed Schonberg <schonberg@adacore.com> + + * sem_prag.adb (Analyze_Pragma, case 'Obsolescent): Pragma is legal + after any declaration, including renaming declarations. + 2009-04-15 Arnaud Charlet <charlet@adacore.com> * gcc-interface/Make-lang.in: Update dependencies. diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 7a4ff3a0959..8476daca115 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -1816,7 +1816,7 @@ __gnat_map_signal (int sig) break; case SIGSEGV: exception = &storage_error; - msg = "SIGSEGV: possible stack overflow"; + msg = "SIGSEGV"; break; case SIGBUS: exception = &storage_error; @@ -1841,7 +1841,7 @@ __gnat_map_signal (int sig) #else /* VxWorks 6 kernel mode with probing. SIGBUS for guard page hit */ case SIGSEGV: - exception = &program_error; + exception = &storage_error; msg = "SIGSEGV"; break; case SIGBUS: @@ -1857,7 +1857,7 @@ __gnat_map_signal (int sig) msg = "SIGILL: possible stack overflow"; break; case SIGSEGV: - exception = &program_error; + exception = &storage_error; msg = "SIGSEGV"; break; case SIGBUS: diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index a8995d9c716..d7d1e3794bc 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -5718,7 +5718,11 @@ package body Make is end if; end if; - if Main_Project /= No_Project then + if Main_Project /= No_Project + and then + Project_Tree.Projects.Table + (Main_Project).Exec_Directory /= No_Path_Information + then declare Exec_File_Name : constant String := Get_Name_String (Executable); diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 441bce96c21..8a9a09b8e30 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -6209,151 +6209,11 @@ package body Prj.Nmsc is Write_Line ("Starting to look for directories"); end if; - -- Check the object directory - - pragma Assert (Object_Dir.Kind = Single, - "Object_Dir is not a single string"); - - -- We set the object directory to its default + -- We set the object directory to its default. It may be set to nil, if + -- there is no sources in the project. Data.Object_Directory := Data.Directory; - if Object_Dir.Value /= Empty_String then - Get_Name_String (Object_Dir.Value); - - if Name_Len = 0 then - Error_Msg - (Project, In_Tree, - "Object_Dir cannot be empty", - Object_Dir.Location); - - else - -- We check that the specified object directory does exist - - Locate_Directory - (Project, - In_Tree, - File_Name_Type (Object_Dir.Value), - Data.Directory.Display_Name, - Data.Object_Directory.Name, - Data.Object_Directory.Display_Name, - Create => "object", - Location => Object_Dir.Location, - Current_Dir => Current_Dir, - Externally_Built => Data.Externally_Built); - - if Data.Object_Directory = No_Path_Information then - - -- The object directory does not exist, report an error if the - -- project is not externally built. - - if not Data.Externally_Built then - Err_Vars.Error_Msg_File_1 := - File_Name_Type (Object_Dir.Value); - Error_Msg - (Project, In_Tree, - "the object directory { cannot be found", - Data.Location); - end if; - - -- Do not keep a nil Object_Directory. Set it to the specified - -- (relative or absolute) path. This is for the benefit of - -- tools that recover from errors; for example, these tools - -- could create the non existent directory. - - Data.Object_Directory.Display_Name := - Path_Name_Type (Object_Dir.Value); - - if Osint.File_Names_Case_Sensitive then - Data.Object_Directory.Name := - Path_Name_Type (Object_Dir.Value); - else - Get_Name_String (Object_Dir.Value); - Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); - Data.Object_Directory.Name := Name_Find; - end if; - end if; - end if; - - elsif Subdirs /= null then - Name_Len := 1; - Name_Buffer (1) := '.'; - Locate_Directory - (Project, - In_Tree, - Name_Find, - Data.Directory.Display_Name, - Data.Object_Directory.Name, - Data.Object_Directory.Display_Name, - Create => "object", - Location => Object_Dir.Location, - Current_Dir => Current_Dir, - Externally_Built => Data.Externally_Built); - end if; - - if Current_Verbosity = High then - if Data.Object_Directory = No_Path_Information then - Write_Line ("No object directory"); - else - Write_Str ("Object directory: """); - Write_Str (Get_Name_String (Data.Object_Directory.Display_Name)); - Write_Line (""""); - end if; - end if; - - -- Check the exec directory - - pragma Assert (Exec_Dir.Kind = Single, - "Exec_Dir is not a single string"); - - -- We set the object directory to its default - - Data.Exec_Directory := Data.Object_Directory; - - if Exec_Dir.Value /= Empty_String then - Get_Name_String (Exec_Dir.Value); - - if Name_Len = 0 then - Error_Msg - (Project, In_Tree, - "Exec_Dir cannot be empty", - Exec_Dir.Location); - - else - -- We check that the specified exec directory does exist - - Locate_Directory - (Project, - In_Tree, - File_Name_Type (Exec_Dir.Value), - Data.Directory.Display_Name, - Data.Exec_Directory.Name, - Data.Exec_Directory.Display_Name, - Create => "exec", - Location => Exec_Dir.Location, - Current_Dir => Current_Dir, - Externally_Built => Data.Externally_Built); - - if Data.Exec_Directory = No_Path_Information then - Err_Vars.Error_Msg_File_1 := File_Name_Type (Exec_Dir.Value); - Error_Msg - (Project, In_Tree, - "the exec directory { cannot be found", - Data.Location); - end if; - end if; - end if; - - if Current_Verbosity = High then - if Data.Exec_Directory = No_Path_Information then - Write_Line ("No exec directory"); - else - Write_Str ("Exec directory: """); - Write_Str (Get_Name_String (Data.Exec_Directory.Display_Name)); - Write_Line (""""); - end if; - end if; - -- Look for the source directories if Current_Verbosity = High then @@ -6492,6 +6352,148 @@ package body Prj.Nmsc is end loop; end; + -- Check the object directory + + pragma Assert (Object_Dir.Kind = Single, + "Object_Dir is not a single string"); + + if Object_Dir.Value /= Empty_String then + Get_Name_String (Object_Dir.Value); + + if Name_Len = 0 then + Error_Msg + (Project, In_Tree, + "Object_Dir cannot be empty", + Object_Dir.Location); + + else + -- We check that the specified object directory does exist + + Locate_Directory + (Project, + In_Tree, + File_Name_Type (Object_Dir.Value), + Data.Directory.Display_Name, + Data.Object_Directory.Name, + Data.Object_Directory.Display_Name, + Create => "object", + Location => Object_Dir.Location, + Current_Dir => Current_Dir, + Externally_Built => Data.Externally_Built); + + if Data.Object_Directory = No_Path_Information then + + -- The object directory does not exist, report an error if the + -- project is not externally built. + + if not Data.Externally_Built then + Err_Vars.Error_Msg_File_1 := + File_Name_Type (Object_Dir.Value); + Error_Msg + (Project, In_Tree, + "the object directory { cannot be found", + Data.Location); + end if; + + -- Do not keep a nil Object_Directory. Set it to the specified + -- (relative or absolute) path. This is for the benefit of + -- tools that recover from errors; for example, these tools + -- could create the non existent directory. + + Data.Object_Directory.Display_Name := + Path_Name_Type (Object_Dir.Value); + + if Osint.File_Names_Case_Sensitive then + Data.Object_Directory.Name := + Path_Name_Type (Object_Dir.Value); + else + Get_Name_String (Object_Dir.Value); + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + Data.Object_Directory.Name := Name_Find; + end if; + end if; + end if; + + elsif Data.Object_Directory /= No_Path_Information and then + Subdirs /= null + then + Name_Len := 1; + Name_Buffer (1) := '.'; + Locate_Directory + (Project, + In_Tree, + Name_Find, + Data.Directory.Display_Name, + Data.Object_Directory.Name, + Data.Object_Directory.Display_Name, + Create => "object", + Location => Object_Dir.Location, + Current_Dir => Current_Dir, + Externally_Built => Data.Externally_Built); + end if; + + if Current_Verbosity = High then + if Data.Object_Directory = No_Path_Information then + Write_Line ("No object directory"); + else + Write_Str ("Object directory: """); + Write_Str (Get_Name_String (Data.Object_Directory.Display_Name)); + Write_Line (""""); + end if; + end if; + + -- Check the exec directory + + pragma Assert (Exec_Dir.Kind = Single, + "Exec_Dir is not a single string"); + + -- We set the object directory to its default + + Data.Exec_Directory := Data.Object_Directory; + + if Exec_Dir.Value /= Empty_String then + Get_Name_String (Exec_Dir.Value); + + if Name_Len = 0 then + Error_Msg + (Project, In_Tree, + "Exec_Dir cannot be empty", + Exec_Dir.Location); + + else + -- We check that the specified exec directory does exist + + Locate_Directory + (Project, + In_Tree, + File_Name_Type (Exec_Dir.Value), + Data.Directory.Display_Name, + Data.Exec_Directory.Name, + Data.Exec_Directory.Display_Name, + Create => "exec", + Location => Exec_Dir.Location, + Current_Dir => Current_Dir, + Externally_Built => Data.Externally_Built); + + if Data.Exec_Directory = No_Path_Information then + Err_Vars.Error_Msg_File_1 := File_Name_Type (Exec_Dir.Value); + Error_Msg + (Project, In_Tree, + "the exec directory { cannot be found", + Data.Location); + end if; + end if; + end if; + + if Current_Verbosity = High then + if Data.Exec_Directory = No_Path_Information then + Write_Line ("No exec directory"); + else + Write_Str ("Exec directory: """); + Write_Str (Get_Name_String (Data.Exec_Directory.Display_Name)); + Write_Line (""""); + end if; + end if; end Get_Directories; --------------- diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 64f2081953f..d075a23f044 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -6130,12 +6130,12 @@ package body Sem_Ch8 is Prev_Use : Node_Id := Empty; Redundant : Node_Id := Empty; - -- The Use_Clause which is actually redundant. In the simplest case - -- it is Pack itself, but when we compile a body we install its - -- context before that of its spec, in which case it is the use_clause - -- in the spec that will appear to be redundant, and we want the - -- warning to be placed on the body. Similar complications appear when - -- the redundancy is between a child unit and one of its ancestors. + -- The Use_Clause which is actually redundant. In the simplest case it + -- is Pack itself, but when we compile a body we install its context + -- before that of its spec, in which case it is the use_clause in the + -- spec that will appear to be redundant, and we want the warning to be + -- placed on the body. Similar complications appear when the redundancy + -- is between a child unit and one of its ancestors. begin Set_Redundant_Use (Clause, True); @@ -6149,12 +6149,12 @@ package body Sem_Ch8 is if not Is_Compilation_Unit (Current_Scope) then - -- If the use_clause is in an inner scope, it is made redundant - -- by some clause in the current context, with one exception: - -- If we're compiling a nested package body, and the use_clause - -- comes from the corresponding spec, the clause is not necessarily - -- fully redundant, so we should not warn. If a warning was - -- warranted, it would have been given when the spec was processed. + -- If the use_clause is in an inner scope, it is made redundant by + -- some clause in the current context, with one exception: If we're + -- compiling a nested package body, and the use_clause comes from the + -- corresponding spec, the clause is not necessarily fully redundant, + -- so we should not warn. If a warning was warranted, it would have + -- been given when the spec was processed. if Nkind (Parent (Decl)) = N_Package_Specification then declare @@ -6249,12 +6249,12 @@ package body Sem_Ch8 is elsif Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Declaration and then Present (Parent_Spec (Unit (Cunit (Current_Sem_Unit)))) then - -- Use_clause is in child unit of current unit, and the child - -- unit appears in the context of the body of the parent, so it - -- has been installed first, even though it is the redundant one. - -- Depending on their placement in the context, the visible or the - -- private parts of the two units, either might appear as redundant, - -- but the message has to be on the current unit. + -- Use_clause is in child unit of current unit, and the child unit + -- appears in the context of the body of the parent, so it has been + -- installed first, even though it is the redundant one. Depending on + -- their placement in the context, the visible or the private parts + -- of the two units, either might appear as redundant, but the + -- message has to be on the current unit. if Get_Source_Unit (Cur_Use) = Current_Sem_Unit then Redundant := Cur_Use; @@ -6367,9 +6367,9 @@ package body Sem_Ch8 is if Ekind (S) = E_Void then null; - -- Set scope depth if not a non-concurrent type, and we have not - -- yet set the scope depth. This means that we have the first - -- occurrence of the scope, and this is where the depth is set. + -- Set scope depth if not a non-concurrent type, and we have not yet set + -- the scope depth. This means that we have the first occurrence of the + -- scope, and this is where the depth is set. elsif (not Is_Type (S) or else Is_Concurrent_Type (S)) and then not Scope_Depth_Set (S) @@ -6427,9 +6427,9 @@ package body Sem_Ch8 is Write_Eol; end if; - -- Deal with copying flags from the previous scope to this one. This - -- is not necessary if either scope is standard, or if the new scope - -- is a child unit. + -- Deal with copying flags from the previous scope to this one. This is + -- not necessary if either scope is standard, or if the new scope is a + -- child unit. if S /= Standard_Standard and then Scope (S) /= Standard_Standard @@ -6711,6 +6711,7 @@ package body Sem_Ch8 is if not From_With_Type (E) then Set_Is_Immediately_Visible (E, Is_Visible_Child_Unit (E) or else In_Open_Scopes (E)); + else pragma Assert (Nkind (Parent (E)) = N_Defining_Program_Unit_Name @@ -7124,10 +7125,10 @@ package body Sem_Ch8 is elsif In_Open_Scopes (Scope (T)) then null; - -- A limited view cannot appear in a use_type clause. However, an - -- access type whose designated type is limited has the flag but - -- is not itself a limited view unless we only have a limited view - -- of its enclosing package. + -- A limited view cannot appear in a use_type clause. However, an access + -- type whose designated type is limited has the flag but is not itself + -- a limited view unless we only have a limited view of its enclosing + -- package. elsif From_With_Type (T) and then From_With_Type (Scope (T)) @@ -7172,8 +7173,8 @@ package body Sem_Ch8 is -- as use visible. The analysis then reinstalls the spec along with -- its context. The use clause P.T is now recognized as redundant, -- but in the wrong context. Do not emit a warning in such cases. - -- Do not emit a warning either if we are in an instance, there - -- is no redundancy between an outer use_clause and one that appears + -- Do not emit a warning either if we are in an instance, there is + -- no redundancy between an outer use_clause and one that appears -- within the generic. and then not Spec_Reloaded_For_Body @@ -7219,10 +7220,10 @@ package body Sem_Ch8 is -- Start of processing for Use_Clause_Known begin - -- If both current use type clause and the use type - -- clause for the type are at the compilation unit level, - -- one of the units must be an ancestor of the other, and - -- the warning belongs on the descendant. + -- If both current use type clause and the use type clause + -- for the type are at the compilation unit level, one of + -- the units must be an ancestor of the other, and the + -- warning belongs on the descendant. if Nkind (Parent (Clause1)) = N_Compilation_Unit and then @@ -7240,6 +7241,16 @@ package body Sem_Ch8 is Unit1 := Unit (Parent (Clause1)); Unit2 := Unit (Parent (Clause2)); + -- If both clauses are on same unit, report redundancy + + if Unit1 = Unit2 then + Error_Msg_Sloc := Sloc (Current_Use_Clause (T)); + Error_Msg_NE + ("& is already use-visible through previous " + & "use_type_clause #?", Clause1, T); + return; + end if; + -- There is a redundant use type clause in a child unit. -- Determine which of the units is more deeply nested. -- If a unit is a package instance, retrieve the entity diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index f6d5209514a..37b6727dc04 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -9229,6 +9229,7 @@ package body Sem_Prag is if Nkind (Decl) not in N_Declaration and then Nkind (Decl) not in N_Later_Decl_Item and then Nkind (Decl) not in N_Generic_Declaration + and then Nkind (Decl) not in N_Renaming_Declaration then Error_Pragma ("pragma% misplaced, " diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index e7c2125c043..1e909a2e8f8 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -885,7 +885,7 @@ package body Sem_Type is then return True; - -- An aggregate is compatible with an array or record type + -- An aggregate is compatible with an array or record type. elsif T2 = Any_Composite and then Ekind (T1) in E_Array_Type .. E_Record_Subtype @@ -1423,15 +1423,37 @@ package body Sem_Type is end if; elsif Is_Numeric_Type (Etype (F1)) - and then - (Has_Abstract_Interpretation (Act1) - or else Has_Abstract_Interpretation (Act2)) + and then Has_Abstract_Interpretation (Act1) then - if It = Disambiguate.It1 then - return Disambiguate.It2; - elsif It = Disambiguate.It2 then - return Disambiguate.It1; - end if; + + -- Current interpretation is not the right one because + -- it expects a numeric operand. Examine all the other + -- ones. + + declare + I : Interp_Index; + It : Interp; + + begin + Get_First_Interp (N, I, It); + + while Present (It.Typ) loop + if + not Is_Numeric_Type (Etype (First_Formal (It.Nam))) + then + if No (Act2) + or else not Has_Abstract_Interpretation (Act2) + or else not Is_Numeric_Type + (Etype (Next_Formal (First_Formal (It.Nam)))) + then + return It; + end if; + end if; + Get_Next_Interp (I, It); + end loop; + + return No_Interp; + end; end if; end if; |
