diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 998166ff18b..317195a3bfb 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,37 @@ +2010-06-21 Robert Dewar + + * exp_ch4.adb (Expand_N_Conditional_Expression): Fold if condition + known at compile time. + +2010-06-21 Gary Dismukes + + * atree.adb: Fix comment typo. + +2010-06-21 Ed Schonberg + + * sem_eval.adb (Test_Ambiguous_Operator): New procedure to check + whether a universal arithmetic expression in a conversion, which is + rewritten from a function call with an expanded name, is ambiguous. + +2010-06-21 Vincent Celier + + * prj-nmsc.adb (Name_Location): New Boolean component Listed, to record + source files in specified list of sources. + (Check_Package_Naming): Remove out parameters Bodies and Specs, as they + are never used. + (Add_Source): Set the Location of the new source + (Process_Exceptions_File_Based): Call Add_Source with the Location + (Get_Sources_From_File): If an exception is found, set its Listed to + True + (Find_Sources): When Source_Files is specified, if an exception is + found, set its Listed to True. Remove any exception that is not in a + specified list of sources. + * prj.ads (Source_Data): New component Location + +2010-06-21 Vincent Celier + + * gnatbind.adb (Closure_Sources): Global table, moved from block. + 2010-06-21 Thomas Quinot * sem_res.adb: Minor reformatting. diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index bed359fa52e..6f1fc55111f 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -108,7 +108,7 @@ package body Atree is -- calls Rewrite_Breakpoint. Otherwise, does nothing. procedure Node_Debug_Output (Op : String; N : Node_Id); - -- Common code for nnr and rrd. Write Op followed by information about N + -- Common code for nnd and rrd. Write Op followed by information about N. ----------------------------- -- Local Objects and Types -- diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index c19024aa44b..10d9dbc4af9 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -2826,9 +2826,9 @@ package body Exp_Ch4 is Insert_Actions (Cnode, Actions, Suppress => All_Checks); - -- Now we construct an array object with appropriate bounds - -- The target is marked as internal, to prevent useless initialization - -- when Initialize_Scalars is enabled. + -- Now we construct an array object with appropriate bounds. We mark + -- the target as internal to prevent useless initialization when + -- Initialize_Scalars is enabled. Ent := Make_Temporary (Loc, 'S'); Set_Is_Internal (Ent); @@ -4025,13 +4025,44 @@ package body Exp_Ch4 is Elsex : constant Node_Id := Next (Thenx); Typ : constant Entity_Id := Etype (N); - Cnn : Entity_Id; - Decl : Node_Id; - New_If : Node_Id; - New_N : Node_Id; - P_Decl : Node_Id; + Cnn : Entity_Id; + Decl : Node_Id; + New_If : Node_Id; + New_N : Node_Id; + P_Decl : Node_Id; + Expr : Node_Id; + Actions : List_Id; begin + -- Fold at compile time if condition known. We have already folded + -- static conditional expressions, but it is possible to fold any + -- case in which the condition is known at compile time, even though + -- the result is non-static. + + -- Note that we don't do the fold of such cases in Sem_Elab because + -- it can cause infinite loops with the expander adding a conditional + -- expression, and Sem_Elab circuitry removing it repeatedly. + + if Compile_Time_Known_Value (Cond) then + if Is_True (Expr_Value (Cond)) then + Expr := Thenx; + Actions := Then_Actions (N); + else + Expr := Elsex; + Actions := Else_Actions (N); + end if; + + Remove (Expr); + Insert_Actions (N, Actions); + Rewrite (N, Relocate_Node (Expr)); + + -- Note that the result is never static (legitimate cases of static + -- conditional expressions were folded in Sem_Eval). + + Set_Is_Static_Expression (N, False); + return; + end if; + -- If the type is limited or unconstrained, we expand as follows to -- avoid any possibility of improper copies. diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb index 8b6edbd3aab..cc06ce39706 100644 --- a/gcc/ada/gnatbind.adb +++ b/gcc/ada/gnatbind.adb @@ -82,6 +82,16 @@ procedure Gnatbind is Mapping_File : String_Ptr := null; + package Closure_Sources is new Table.Table + (Table_Component_Type => File_Name_Type, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Gnatbind.Closure_Sources"); + -- Table to record the sources in the closure, to avoid duplications. Used + -- only with switch -R. + function Gnatbind_Supports_Auto_Init return Boolean; -- Indicates if automatic initialization of elaboration procedure -- through the constructor mechanism is possible on the platform. @@ -817,16 +827,6 @@ begin if List_Closure then declare - package Sources is new Table.Table - (Table_Component_Type => File_Name_Type, - Table_Index_Type => Natural, - Table_Low_Bound => 1, - Table_Initial => 10, - Table_Increment => 100, - Table_Name => "Gnatbind.Sources"); - -- Table to record the sources in the closure, to avoid - -- dupications. - Source : File_Name_Type; function Put_In_Sources (S : File_Name_Type) return Boolean; @@ -842,17 +842,19 @@ begin return Boolean is begin - for J in 1 .. Sources.Last loop - if Sources.Table (J) = S then + for J in 1 .. Closure_Sources.Last loop + if Closure_Sources.Table (J) = S then return False; end if; end loop; - Sources.Append (S); + Closure_Sources.Append (S); return True; end Put_In_Sources; begin + Closure_Sources.Init; + if not Zero_Formatting then Write_Eol; Write_Str ("REFERENCED SOURCES"); diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index ecfa4cee7ac..7932486ed7a 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -54,10 +54,11 @@ package body Prj.Nmsc is Name : File_Name_Type; -- ??? duplicates the key Location : Source_Ptr; Source : Source_Id := No_Source; + Listed : Boolean := False; Found : Boolean := False; end record; No_Name_Location : constant Name_Location := - (No_File, No_Location, No_Source, False); + (No_File, No_Location, No_Source, False, False); package Source_Names_Htable is new GNAT.Dynamic_HTables.Simple_HTable (Header_Num => Header_Num, Element => Name_Location, @@ -234,13 +235,9 @@ package body Prj.Nmsc is procedure Check_Package_Naming (Project : Project_Id; - Data : in out Tree_Processing_Data; - Bodies : out Array_Element_Id; - Specs : out Array_Element_Id); + Data : in out Tree_Processing_Data); -- Check the naming scheme part of Data, and initialize the naming scheme - -- data in the config of the various languages. This also returns the - -- naming scheme exceptions for unit-based languages (Bodies and Specs are - -- associative arrays mapping individual unit names to source file names). + -- data in the config of the various languages. procedure Check_Configuration (Project : Project_Id; @@ -727,6 +724,7 @@ package body Prj.Nmsc is end if; Id.Project := Project; + Id.Location := Location; Id.Source_Dir_Rank := Source_Dir_Rank; Id.Language := Lang_Id; Id.Kind := Kind; @@ -816,8 +814,6 @@ package body Prj.Nmsc is (Project : Project_Id; Data : in out Tree_Processing_Data) is - Specs : Array_Element_Id; - Bodies : Array_Element_Id; Extending : Boolean := False; Prj_Data : Project_Processing_Data; @@ -889,7 +885,7 @@ package body Prj.Nmsc is Extending := Project.Extends /= No_Project; - Check_Package_Naming (Project, Data, Bodies => Bodies, Specs => Specs); + Check_Package_Naming (Project, Data); -- Find the sources @@ -2722,9 +2718,7 @@ package body Prj.Nmsc is procedure Check_Package_Naming (Project : Project_Id; - Data : in out Tree_Processing_Data; - Bodies : out Array_Element_Id; - Specs : out Array_Element_Id) + Data : in out Tree_Processing_Data) is Naming_Id : constant Package_Id := Util.Value_Of @@ -2957,7 +2951,8 @@ package body Prj.Nmsc is Kind => Kind, File_Name => File_Name, Display_File => File_Name_Type (Element.Value), - Naming_Exception => True); + Naming_Exception => True, + Location => Element.Location); else -- Check if the file name is already recorded for another @@ -3380,9 +3375,6 @@ package body Prj.Nmsc is -- Start of processing for Check_Naming_Schemes begin - Specs := No_Array_Element; - Bodies := No_Array_Element; - -- No Naming package or parsing a configuration file? nothing to do if Naming_Id /= No_Package @@ -5557,7 +5549,11 @@ package body Prj.Nmsc is (Name => Source_Name, Location => Location, Source => No_Source, + Listed => True, Found => False); + + else + Name_Loc.Listed := True; end if; Source_Names_Htable.Set @@ -6292,11 +6288,16 @@ package body Prj.Nmsc is (Name => Name, Location => Location, Source => No_Source, + Listed => True, Found => False); - Source_Names_Htable.Set - (Project.Source_Names, Name, Name_Loc); + + else + Name_Loc.Listed := True; end if; + Source_Names_Htable.Set + (Project.Source_Names, Name, Name_Loc); + Current := Element.Next; end loop; @@ -6343,6 +6344,57 @@ package body Prj.Nmsc is Has_Explicit_Sources := False; end if; + -- Remove any exception that is not in the specified list of sources + + if Has_Explicit_Sources then + declare + Source : Source_Id; + Iter : Source_Iterator; + NL : Name_Location; + Again : Boolean; + begin + Iter_Loop : + loop + Again := False; + Iter := For_Each_Source (Data.Tree, Project.Project); + + Source_Loop : + loop + Source := Prj.Element (Iter); + exit Source_Loop when Source = No_Source; + + if Source.Naming_Exception then + NL := Source_Names_Htable.Get + (Project.Source_Names, Source.File); + + if NL /= No_Name_Location and then not NL.Listed then + -- Remove the exception + Source_Names_Htable.Set + (Project.Source_Names, + Source.File, + No_Name_Location); + Remove_Source (Source, No_Source); + + Error_Msg_Name_1 := Name_Id (Source.File); + Error_Msg + (Data.Flags, + "? unknown source file %%", + NL.Location, + Project.Project); + + Again := True; + exit Source_Loop; + end if; + end if; + + Next (Iter); + end loop Source_Loop; + + exit Iter_Loop when not Again; + end loop Iter_Loop; + end; + end if; + Search_Directories (Project, Data => Data, @@ -7031,8 +7083,9 @@ package body Prj.Nmsc is K => Source.File, E => Name_Location' (Name => Source.File, - Location => No_Location, + Location => Source.Location, Source => Source, + Listed => False, Found => False)); -- If this is an Ada exception, record in table Unit_Exceptions diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index 434145027e2..cba9c6f1b36 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -667,6 +667,10 @@ package Prj is Project : Project_Id := No_Project; -- Project of the source + Location : Source_Ptr := No_Location; + -- Location in the project file of the declaration of the source in + -- package Naming. + Source_Dir_Rank : Natural := 0; -- The rank of the source directory in list declared with attribute -- Source_Dirs. Two source files with the same name cannot appears in @@ -768,6 +772,7 @@ package Prj is No_Source_Data : constant Source_Data := (Project => No_Project, + Location => No_Location, Source_Dir_Rank => 0, Language => No_Language_Index, In_Interfaces => True, diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 53c5e48b0c4..b2a29a577db 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -180,6 +180,13 @@ package body Sem_Eval is -- used for producing the result of the static evaluation of the -- logical operators + procedure Test_Ambiguous_Operator (N : Node_Id); + -- Check whether an arithmetic operation with universal operands which + -- is a rewritten function call with an explicit scope indication is + -- ambiguous: P."+" (1, 2) will be ambiguous if there is more than one + -- visible numeric type declared in P and the context does not impose a + -- type on the result (e.g. in the expression of a type conversion). + procedure Test_Expression_Is_Foldable (N : Node_Id; Op1 : Node_Id; @@ -1458,6 +1465,15 @@ package body Sem_Eval is return; end if; + if (Etype (Right) = Universal_Integer + or else Etype (Right) = Universal_Real) + and then + (Etype (Left) = Universal_Integer + or else Etype (Left) = Universal_Real) + then + Test_Ambiguous_Operator (N); + end if; + -- Fold for cases where both operands are of integer type if Is_Integer_Type (Ltype) and then Is_Integer_Type (Rtype) then @@ -3395,6 +3411,12 @@ package body Sem_Eval is return; end if; + if Etype (Right) = Universal_Integer + or else Etype (Right) = Universal_Real + then + Test_Ambiguous_Operator (N); + end if; + -- Fold for integer case if Is_Integer_Type (Etype (N)) then @@ -4699,6 +4721,78 @@ package body Sem_Eval is end if; end Test; + ----------------------------- + -- Test_Ambiguous_Operator -- + ----------------------------- + + procedure Test_Ambiguous_Operator (N : Node_Id) is + Call : constant Node_Id := Original_Node (N); + Is_Int : constant Boolean := Is_Integer_Type (Etype (N)); + + Is_Fix : constant Boolean := + Nkind (N) in N_Binary_Op + and then Nkind (Right_Opnd (N)) /= Nkind (Left_Opnd (N)); + -- a mixed-mode operation in this context indicates the + -- presence of fixed-point type in the designated package. + + E : Entity_Id; + Pack : Entity_Id; + Typ1 : Entity_Id; + Priv_E : Entity_Id; + + begin + if Nkind (Call) /= N_Function_Call + or else Nkind (Name (Call)) /= N_Expanded_Name + then + return; + + elsif Nkind (Parent (N)) = N_Type_Conversion then + Pack := Entity (Prefix (Name (Call))); + + -- If the prefix is a package declared elsewhere, iterate over + -- its visible entities, otherwise iterate over all declarations + -- in the designated scope. + + if Ekind (Pack) = E_Package + and then not In_Open_Scopes (Pack) + then + Priv_E := First_Private_Entity (Pack); + else + Priv_E := Empty; + end if; + + Typ1 := Empty; + E := First_Entity (Pack); + while Present (E) + and then E /= Priv_E + loop + if Is_Numeric_Type (E) + and then Nkind (Parent (E)) /= N_Subtype_Declaration + and then Comes_From_Source (E) + and then Is_Integer_Type (E) = Is_Int + and then + (Nkind (N) in N_Unary_Op + or else Is_Fixed_Point_Type (E) = Is_Fix) + then + if No (Typ1) then + Typ1 := E; + + else + -- More than one type of the proper class declared in P + + Error_Msg_N ("ambiguous operation", N); + Error_Msg_Sloc := Sloc (Typ1); + Error_Msg_N ("\possible interpretation (inherited)#", N); + Error_Msg_Sloc := Sloc (E); + Error_Msg_N ("\possible interpretation (inherited)#", N); + end if; + end if; + + Next_Entity (E); + end loop; + end if; + end Test_Ambiguous_Operator; + --------------------------------- -- Test_Expression_Is_Foldable -- ---------------------------------