diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 7babb507592..a572f6cde9e 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,28 @@ +2011-08-03 Gary Dismukes + + * sem_ch3.adb (Build_Derived_Record_Type): Test the Derive_Subps formal + as a condition for the delayed call to Derived_Subprograms done for the + case of the rewriting of a derived type that constrains the + discriminants of its parent type. + Avoids redundant subprogram derivations for private subtype derivations. + +2011-08-03 Javier Miranda + + * exp_aggr.adb (Init_Hidden_Discriminants): New subprogram of + Build_Record_Aggr_Code. + (Build_Record_Aggr_Code): Add missing support to initialize hidden + discriminants in extension aggregates. + +2011-08-03 Emmanuel Briot + + * prj-pp.adb (Print): also output project qualifiers, since in + particular "aggregate" is mandatory in an aggregate project. + +2011-08-03 Emmanuel Briot + + * prj-part.adb, prj.adb, prj.ads, prj-nmsc.adb, prj-env.adb: + (Debug_Output): new function. + 2011-08-03 Eric Botcazou * gnat_ugn.texi: Document -Wstack-usage. diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index f04a662a7fc..c083805761c 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -1854,6 +1854,11 @@ package body Exp_Aggr is -- to finalization list F. Init_Pr conditions the call to the init proc -- since it may already be done due to ancestor initialization. + procedure Init_Hidden_Discriminants (Typ : Entity_Id; List : List_Id); + -- If Typ is derived, and constrains discriminants of the parent type, + -- these discriminants are not components of the aggregate, and must be + -- initialized. The assignments are appended to List. + function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean; -- Check whether Bounds is a range node and its lower and higher bounds -- are integers literals. @@ -2156,6 +2161,56 @@ package body Exp_Aggr is return L; end Init_Controller; + ------------------------------- + -- Init_Hidden_Discriminants -- + ------------------------------- + + procedure Init_Hidden_Discriminants (Typ : Entity_Id; List : List_Id) is + Btype : Entity_Id; + Parent_Type : Entity_Id; + Disc : Entity_Id; + Discr_Val : Elmt_Id; + + begin + Btype := Base_Type (Typ); + while Is_Derived_Type (Btype) + and then Present (Stored_Constraint (Btype)) + loop + Parent_Type := Etype (Btype); + + Disc := First_Discriminant (Parent_Type); + Discr_Val := First_Elmt (Stored_Constraint (Base_Type (Typ))); + while Present (Discr_Val) loop + + -- Only those discriminants of the parent that are not + -- renamed by discriminants of the derived type need to + -- be added explicitly. + + if not Is_Entity_Name (Node (Discr_Val)) + or else Ekind (Entity (Node (Discr_Val))) /= E_Discriminant + then + Comp_Expr := + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => New_Occurrence_Of (Disc, Loc)); + + Instr := + Make_OK_Assignment_Statement (Loc, + Name => Comp_Expr, + Expression => New_Copy_Tree (Node (Discr_Val))); + + Set_No_Ctrl_Actions (Instr); + Append_To (List, Instr); + end if; + + Next_Discriminant (Disc); + Next_Elmt (Discr_Val); + end loop; + + Btype := Base_Type (Parent_Type); + end loop; + end Init_Hidden_Discriminants; + ------------------------- -- Is_Int_Range_Bounds -- ------------------------- @@ -2741,6 +2796,17 @@ package body Exp_Aggr is end if; end; + -- Generate assignments of hidden assignments. If the base type is an + -- unchecked union, the discriminants are unknown to the back-end and + -- absent from a value of the type, so assignments for them are not + -- emitted. + + if Has_Discriminants (Typ) + and then not Is_Unchecked_Union (Base_Type (Typ)) + then + Init_Hidden_Discriminants (Typ, L); + end if; + -- Normal case (not an extension aggregate) else @@ -2752,59 +2818,7 @@ package body Exp_Aggr is if Has_Discriminants (Typ) and then not Is_Unchecked_Union (Base_Type (Typ)) then - -- If the type is derived, and constrains discriminants of the - -- parent type, these discriminants are not components of the - -- aggregate, and must be initialized explicitly. They are not - -- visible components of the object, but can become visible with - -- a view conversion to the ancestor. - - declare - Btype : Entity_Id; - Parent_Type : Entity_Id; - Disc : Entity_Id; - Discr_Val : Elmt_Id; - - begin - Btype := Base_Type (Typ); - while Is_Derived_Type (Btype) - and then Present (Stored_Constraint (Btype)) - loop - Parent_Type := Etype (Btype); - - Disc := First_Discriminant (Parent_Type); - Discr_Val := - First_Elmt (Stored_Constraint (Base_Type (Typ))); - while Present (Discr_Val) loop - - -- Only those discriminants of the parent that are not - -- renamed by discriminants of the derived type need to - -- be added explicitly. - - if not Is_Entity_Name (Node (Discr_Val)) - or else - Ekind (Entity (Node (Discr_Val))) /= E_Discriminant - then - Comp_Expr := - Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Target), - Selector_Name => New_Occurrence_Of (Disc, Loc)); - - Instr := - Make_OK_Assignment_Statement (Loc, - Name => Comp_Expr, - Expression => New_Copy_Tree (Node (Discr_Val))); - - Set_No_Ctrl_Actions (Instr); - Append_To (L, Instr); - end if; - - Next_Discriminant (Disc); - Next_Elmt (Discr_Val); - end loop; - - Btype := Base_Type (Parent_Type); - end loop; - end; + Init_Hidden_Discriminants (Typ, L); -- Generate discriminant init values for the visible discriminants diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb index f162bb1bba0..4598a6958bf 100644 --- a/gcc/ada/prj-env.adb +++ b/gcc/ada/prj-env.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -782,13 +782,12 @@ package body Prj.Env is procedure Put_Name_Buffer is begin - Name_Len := Name_Len + 1; - Name_Buffer (Name_Len) := ASCII.LF; - if Current_Verbosity = High then - Write_Str ("Mapping file: " & Name_Buffer (1 .. Name_Len)); + Debug_Output (Name_Buffer (1 .. Name_Len)); end if; + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := ASCII.LF; Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last); end Put_Name_Buffer; @@ -875,6 +874,12 @@ package body Prj.Env is -- Start of processing for Create_Mapping_File begin + Create_Temp_File (In_Tree, File, Name, "mapping"); + + if Current_Verbosity = High then + Debug_Increase_Indent ("Create mapping file ", Name_Id (Name)); + end if; + For_Every_Imported_Project (Project, Dummy); declare @@ -882,8 +887,6 @@ package body Prj.Env is Status : Boolean := False; begin - Create_Temp_File (In_Tree, File, Name, "mapping"); - if File /= Invalid_FD then Last := Write (File, Buffer (1)'Address, Buffer_Last); @@ -898,6 +901,8 @@ package body Prj.Env is end; Free (Buffer); + + Debug_Decrease_Indent ("Done create mapping file"); end Create_Mapping_File; ---------------------- @@ -2021,8 +2026,7 @@ package body Prj.Env is begin if Current_Verbosity = High then - Write_Str (" Trying "); - Write_Line (Path); + Debug_Output ("Trying " & Path); end if; if Is_Absolute_Path (Path) then @@ -2064,8 +2068,7 @@ package body Prj.Env is Add_Str_To_Name_Buffer (Path); if Current_Verbosity = High then - Write_Str (" Testing file "); - Write_Line (Name_Buffer (1 .. Name_Len)); + Debug_Output ("Testing file " & Name_Buffer (1 .. Name_Len)); end if; if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then @@ -2092,11 +2095,9 @@ package body Prj.Env is Initialize_Project_Path (Self, Target_Name); if Current_Verbosity = High then - Write_Str ("Searching for project ("""); - Write_Str (File); - Write_Str (""", """); - Write_Str (Directory); - Write_Line (""");"); + Debug_Increase_Indent + ("Searching for project """ & File & """ in """ + & Directory & '"'); end if; -- Check the project cache @@ -2107,6 +2108,7 @@ package body Prj.Env is Path := Projects_Paths.Get (Self.Cache, Key); if Path /= No_Path then + Debug_Decrease_Indent; return; end if; @@ -2176,6 +2178,8 @@ package body Prj.Env is Projects_Paths.Set (Self.Cache, Key, Path); end; end if; + + Debug_Decrease_Indent; end Find_Project; ---------- diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 1baba1a6e37..5b9ae4c0922 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -624,10 +624,7 @@ package body Prj.Nmsc is procedure Write_Attr (Name, Value : String) is begin if Current_Verbosity = High then - Write_Str (" " & Name & " = """); - Write_Str (Value); - Write_Char ('"'); - Write_Eol; + Debug_Output (Name & " = """ & Value & '"'); end if; end Write_Attr; @@ -804,6 +801,7 @@ package body Prj.Nmsc is Id := new Source_Data; if Current_Verbosity = High then + Debug_Indent; Write_Str ("Adding source File: "); Write_Str (Get_Name_String (Display_File)); @@ -939,11 +937,13 @@ package body Prj.Nmsc is Data.Tree); procedure Found_Project_File (Path : Path_Information; Rank : Natural); - -- Comments required ??? + -- Called for each project file aggregated by Project procedure Expand_Project_Files is new Expand_Subdirectory_Pattern (Callback => Found_Project_File); - -- Comments required ??? + -- Search for all project files referenced by the patterns given in + -- parameter. + -- Calls Found_Project_File for each of them ------------------------ -- Found_Project_File -- @@ -952,10 +952,8 @@ package body Prj.Nmsc is procedure Found_Project_File (Path : Path_Information; Rank : Natural) is pragma Unreferenced (Rank); begin - if Current_Verbosity = High then - Write_Str (" Aggregates:"); - Write_Line (Get_Name_String (Path.Display_Name)); - end if; + Debug_Output ("Aggregates: ", Name_Id (Path.Display_Name)); + end Found_Project_File; -- Start of processing for Check_Aggregate_Project @@ -982,7 +980,6 @@ package body Prj.Nmsc is Ignore => Nil_String, Search_For => Search_Files, Resolve_Links => Opt.Follow_Links_For_Files); - end Check_Aggregate_Project; ---------------------------- @@ -1040,6 +1037,8 @@ package body Prj.Nmsc is Prj_Data : Project_Processing_Data; begin + Debug_Increase_Indent ("Check ", Project.Name); + Initialize (Prj_Data, Project); Check_If_Externally_Built (Project, Data); @@ -1079,6 +1078,8 @@ package body Prj.Nmsc is end if; Free (Prj_Data); + + Debug_Decrease_Indent ("Done Check"); end Check; -------------------- @@ -1125,12 +1126,7 @@ package body Prj.Nmsc is and then Name not in Ada_2005_Reserved_Words then Unit := No_Name; - - if Current_Verbosity = High then - Write_Str (The_Name); - Write_Line (" is an Ada reserved word."); - end if; - + Debug_Output ("Ada reserved word: ", Name); return True; else @@ -1183,6 +1179,7 @@ package body Prj.Nmsc is OK := False; if Current_Verbosity = High then + Debug_Indent; Write_Int (Types.Int (Index)); Write_Str (": '"); Write_Char (The_Name (Index)); @@ -1201,6 +1198,7 @@ package body Prj.Nmsc is OK := False; if Current_Verbosity = High then + Debug_Indent; Write_Int (Types.Int (Index)); Write_Str (": '"); Write_Char (The_Name (Index)); @@ -1235,6 +1233,7 @@ package body Prj.Nmsc is OK := False; if Current_Verbosity = High then + Debug_Indent; Write_Int (Types.Int (Index)); Write_Str (": '"); Write_Char (The_Name (Index)); @@ -2682,14 +2681,10 @@ package body Prj.Nmsc is Project.Externally_Built := Project.Extends.Externally_Built; end if; - if Current_Verbosity = High then - Write_Str ("Project is "); - - if not Project.Externally_Built then - Write_Str ("not "); - end if; - - Write_Line ("externally built."); + if Project.Externally_Built then + Debug_Output ("Project is externally built"); + else + Debug_Output ("Project is not externally built"); end if; end Check_If_Externally_Built; @@ -2766,10 +2761,8 @@ package body Prj.Nmsc is Other.Declared_In_Interfaces := True; end if; - if Current_Verbosity = High then - Write_Str (" interface: "); - Write_Line (Get_Name_String (Source.Path.Name)); - end if; + Debug_Output + ("interface: ", Name_Id (Source.Path.Name)); end if; exit Big_Loop; @@ -2845,10 +2838,8 @@ package body Prj.Nmsc is Other.Declared_In_Interfaces := True; end if; - if Current_Verbosity = High then - Write_Str (" interface: "); - Write_Line (Get_Name_String (Source.Path.Name)); - end if; + Debug_Output + ("interface: ", Name_Id (Source.Path.Name)); end if; exit Big_Loop_2; @@ -3497,12 +3488,9 @@ package body Prj.Nmsc is -- If language was not found in project or the projects it extends if Lang = null then - if Current_Verbosity = High then - Write_Line - ("Ignoring spec naming data for " - & Get_Name_String (Lang_Name) - & " since language is not defined for this project"); - end if; + Debug_Output + ("Ignoring spec naming data (lang. not in project): ", + Lang_Name); else Value := Data.Tree.Array_Elements.Table (Specs).Value; @@ -3523,12 +3511,9 @@ package body Prj.Nmsc is (Project, Name => Get_Name_String (Lang_Name)); if Lang = null then - if Current_Verbosity = High then - Write_Line - ("Ignoring impl naming data for " - & Get_Name_String (Lang_Name) - & " since language is not defined for this project"); - end if; + Debug_Output + ("Ignoring impl naming data (lang. not in project): ", + Lang_Name); else Value := Data.Tree.Array_Elements.Table (Impls).Value; @@ -3555,14 +3540,10 @@ package body Prj.Nmsc is and then Project.Qualifier /= Configuration then Naming := Data.Tree.Packages.Table (Naming_Id); - - if Current_Verbosity = High then - Write_Line ("Checking package Naming for project " - & Get_Name_String (Project.Name)); - end if; - + Debug_Increase_Indent ("Checking package Naming for ", Project.Name); Initialize_Naming_Data; Check_Naming; + Debug_Decrease_Indent ("Done checking package naming"); end if; end Check_Package_Naming; @@ -3747,6 +3728,7 @@ package body Prj.Nmsc is if Current_Verbosity = High and then Project.Library_Name = No_Name then + Debug_Indent; Write_Line ("No library name"); end if; @@ -3758,16 +3740,14 @@ package body Prj.Nmsc is if Project.Library_Name /= No_Name then if Current_Verbosity = High then - Write_Attr - ("Library name", Get_Name_String (Project.Library_Name)); + Write_Attr ("Library name: ", + Get_Name_String (Project.Library_Name)); end if; pragma Assert (Lib_Dir.Kind = Single); if not Library_Directory_Present then - if Current_Verbosity = High then - Write_Line ("No library directory"); - end if; + Debug_Output ("No library directory"); else -- Find path name (unless inherited), check that it is a directory @@ -3960,10 +3940,7 @@ package body Prj.Nmsc is else if Lib_ALI_Dir.Value = Empty_String then - if Current_Verbosity = High then - Write_Line ("No library ALI directory specified"); - end if; - + Debug_Output ("No library ALI directory specified"); Project.Library_ALI_Dir := Project.Library_Dir; else @@ -4101,9 +4078,7 @@ package body Prj.Nmsc is pragma Assert (Lib_Version.Kind = Single); if Lib_Version.Value = Empty_String then - if Current_Verbosity = High then - Write_Line ("No library version specified"); - end if; + Debug_Output ("No library version specified"); else Project.Lib_Internal_Name := Lib_Version.Value; @@ -4112,9 +4087,7 @@ package body Prj.Nmsc is pragma Assert (The_Lib_Kind.Kind = Single); if The_Lib_Kind.Value = Empty_String then - if Current_Verbosity = High then - Write_Line ("No library kind specified"); - end if; + Debug_Output ("No library kind specified"); else Get_Name_String (The_Lib_Kind.Value); @@ -4199,9 +4172,7 @@ package body Prj.Nmsc is end if; if Project.Library then - if Current_Verbosity = High then - Write_Line ("This is a library project file"); - end if; + Debug_Output ("This is a library project file"); Check_Library (Project.Extends, Extends => True); @@ -5080,10 +5051,7 @@ package body Prj.Nmsc is -- The directory is in the list if List is not Nil_String if not Remove_Source_Dirs and then List = Nil_String then - if Current_Verbosity = High then - Write_Str (" Adding Source Dir="); - Write_Line (Get_Name_String (Path.Display_Name)); - end if; + Debug_Output ("Adding source dir=", Name_Id (Path.Display_Name)); String_Element_Table.Increment_Last (Data.Tree.String_Elements); Element := @@ -5162,9 +5130,7 @@ package body Prj.Nmsc is -- Start of processing for Get_Directories begin - if Current_Verbosity = High then - Write_Line ("Starting to look for directories"); - end if; + Debug_Output ("Starting to look for directories"); -- Set the object directory to its default which may be nil, if there -- is no sources in the project. @@ -5283,19 +5249,17 @@ package body Prj.Nmsc is if Current_Verbosity = High then if Project.Exec_Directory = No_Path_Information then - Write_Line ("No exec directory"); + Debug_Output ("No exec directory"); else - Write_Str ("Exec directory: """); - Write_Str (Get_Name_String (Project.Exec_Directory.Display_Name)); - Write_Line (""""); + Debug_Output + ("Exec directory: ", + Name_Id (Project.Exec_Directory.Display_Name)); end if; end if; -- Look for the source directories - if Current_Verbosity = High then - Write_Line ("Starting to look for source directories"); - end if; + Debug_Output ("Starting to look for source directories"); pragma Assert (Source_Dirs.Kind = List, "Source_Dirs is not a list"); @@ -5355,9 +5319,7 @@ package body Prj.Nmsc is Resolve_Links => Opt.Follow_Links_For_Dirs); end if; - if Current_Verbosity = High then - Write_Line ("Putting source directories in canonical cases"); - end if; + Debug_Output ("Putting source directories in canonical cases"); declare Current : String_List_Id := Project.Source_Dirs; @@ -5446,9 +5408,7 @@ package body Prj.Nmsc is begin if Current_Verbosity = High then - Write_Str ("Opening """); - Write_Str (Path); - Write_Line ("""."); + Debug_Output ("Opening """ & Path & '"'); end if; -- Open the file @@ -5556,10 +5516,7 @@ package body Prj.Nmsc is end if; if Naming.Dot_Replacement = No_File then - if Current_Verbosity = High then - Write_Line (" No dot_replacement specified"); - end if; - + Debug_Output ("No dot_replacement specified"); return; end if; @@ -5592,10 +5549,7 @@ package body Prj.Nmsc is end if; if Last = Filename'Last then - if Current_Verbosity = High then - Write_Line (" no matching suffix"); - end if; - + Debug_Output ("no matching suffix"); return; end if; @@ -5608,10 +5562,7 @@ package body Prj.Nmsc is if Is_Letter (Filename (J)) and then not Is_Lower (Filename (J)) then - if Current_Verbosity = High then - Write_Line (" Invalid casing"); - end if; - + Debug_Output ("Invalid casing"); return; end if; end loop; @@ -5621,10 +5572,7 @@ package body Prj.Nmsc is if Is_Letter (Filename (J)) and then not Is_Upper (Filename (J)) then - if Current_Verbosity = High then - Write_Line (" Invalid casing"); - end if; - + Debug_Output ("Invalid casing"); return; end if; end loop; @@ -5645,10 +5593,7 @@ package body Prj.Nmsc is if Dot_Repl /= "." then for Index in Filename'First .. Last loop if Filename (Index) = '.' then - if Current_Verbosity = High then - Write_Line (" Invalid name, contains dot"); - end if; - + Debug_Output ("Invalid name, contains dot"); return; end if; end loop; @@ -5731,6 +5676,7 @@ package body Prj.Nmsc is if Masked then if Current_Verbosity = High then + Debug_Indent; Write_Str (" """ & Filename & """ contains the "); if Kind = Spec then @@ -5752,12 +5698,10 @@ package body Prj.Nmsc is and then Current_Verbosity = High then case Kind is - when Spec => Write_Str (" spec of "); - when Impl => Write_Str (" body of "); - when Sep => Write_Str (" sep of "); + when Spec => Debug_Output ("spec of", Unit); + when Impl => Debug_Output ("body of", Unit); + when Sep => Debug_Output ("sep of", Unit); end case; - - Write_Line (Get_Name_String (Unit)); end if; end Compute_Unit_Name; @@ -5869,9 +5813,10 @@ package body Prj.Nmsc is The_Name := Name_Find; if Current_Verbosity = High then + Debug_Indent; Write_Str ("Locate_Directory ("""); Write_Str (Get_Name_String (The_Name)); - Write_Str (""", """); + Write_Str (""", in """); Write_Str (The_Parent); Write_Line (""")"); end if; @@ -6411,6 +6356,7 @@ package body Prj.Nmsc is Source.Path := Path; if Current_Verbosity = High then + Debug_Indent; if Source.Path /= No_Path_Information then Write_Line ("Setting full path for " & Get_Name_String (Source.File) @@ -6562,16 +6508,12 @@ package body Prj.Nmsc is Kind := Impl; Language := Tmp_Lang; - if Current_Verbosity = High then - Write_Str (" implementation of language "); - Write_Line (Get_Name_String (Display_Language_Name)); - end if; + Debug_Output + ("Implementation of language ", Display_Language_Name); elsif Suffix_Matches (Filename, Config.Naming_Data.Spec_Suffix) then - if Current_Verbosity = High then - Write_Str (" header of language "); - Write_Line (Get_Name_String (Display_Language_Name)); - end if; + Debug_Output + ("Header of language ", Display_Language_Name); if Header_File then Alternate_Languages := new Language_List_Element' @@ -6600,8 +6542,8 @@ package body Prj.Nmsc is Tmp_Lang := Project.Project.Languages; while Tmp_Lang /= No_Language_Index loop if Current_Verbosity = High then - Write_Line - (" Testing language " + Debug_Output + ("Testing language " & Get_Name_String (Tmp_Lang.Name) & " Header_File=" & Header_File'Img); end if; @@ -6639,10 +6581,8 @@ package body Prj.Nmsc is Tmp_Lang := Tmp_Lang.Next; end loop; - if Language = No_Language_Index - and then Current_Verbosity = High - then - Write_Line (" not a source of any language"); + if Language = No_Language_Index then + Debug_Output ("not a source of any language"); end if; end Check_File_Naming_Schemes; @@ -6674,9 +6614,9 @@ package body Prj.Nmsc is if Current_Verbosity = High and then Source.File /= No_File then - Write_Line ("Override kind for " - & Get_Name_String (Source.File) - & " kind=" & Source.Kind'Img); + Debug_Output ("Override kind for " + & Get_Name_String (Source.File) + & " kind=" & Source.Kind'Img); end if; if Source.Kind in Spec_Or_Body and then Source.Unit /= null then @@ -6714,11 +6654,9 @@ package body Prj.Nmsc is begin if Current_Verbosity = High then - Write_Line ("Checking file:"); - Write_Str (" Path = "); - Write_Line (Get_Name_String (Path)); - Write_Str (" Rank ="); - Write_Line (Source_Dir_Rank'Img); + Debug_Increase_Indent + ("Checking file (rank=" & Source_Dir_Rank'Img & ")", + Name_Id (Path)); end if; if Name_Loc = No_Name_Location then @@ -6825,6 +6763,8 @@ package body Prj.Nmsc is end if; end if; end if; + + Debug_Decrease_Indent; end Check_File; --------------------------------- @@ -6938,11 +6878,7 @@ package body Prj.Nmsc is Success : Boolean := False; begin - if Current_Verbosity = High then - Write_Str (" Looking for subdirs of """); - Write_Str (Path_Str); - Write_Line (""""); - end if; + Debug_Output ("Looking for subdirs of ", Name_Id (Path.Display_Name)); if Recursive_Dirs.Get (Visited, Path.Name) then return Success; @@ -7038,11 +6974,7 @@ package body Prj.Nmsc is Success : Boolean; begin - if Current_Verbosity = High then - Write_Str ("Expand_Subdirectory_Pattern ("""); - Write_Str (Pattern); - Write_Line (""")"); - end if; + Debug_Increase_Indent ("Find_Pattern", Pattern_Id); -- If we are looking for files, find the pattern for the files @@ -7063,9 +6995,10 @@ package body Prj.Nmsc is end if; if Current_Verbosity = High then - Write_Str (" file pattern="); - Write_Line (Pattern (Pattern_End + 1 .. Pattern'Last)); - Write_Str (" Expand directory pattern="); + Debug_Indent; + Write_Str ("file_pattern="); + Write_Str (Pattern (Pattern_End + 1 .. Pattern'Last)); + Write_Str (" dir_pattern="); Write_Line (Pattern (Pattern'First .. Pattern_End)); end if; @@ -7138,6 +7071,8 @@ package body Prj.Nmsc is end case; end if; end if; + + Debug_Decrease_Indent ("Done Find_Pattern"); end Find_Pattern; -- Local variables @@ -7179,9 +7114,7 @@ package body Prj.Nmsc is Display_File_Name : File_Name_Type; begin - if Current_Verbosity = High then - Write_Line ("Looking for sources:"); - end if; + Debug_Increase_Indent ("Looking for sources"); -- Loop through subdirectories @@ -7213,10 +7146,10 @@ package body Prj.Nmsc is begin if Current_Verbosity = High then - Write_Attr - ("Source_Dir", - Source_Directory (Source_Directory'First .. Dir_Last)); - Write_Line (Num_Nod.Number'Img); + Debug_Increase_Indent + ("Source_Dir (node=" & Num_Nod.Number'Img & ") """ + & Source_Directory (Source_Directory'First .. Dir_Last) + & '"'); end if; -- We look to every entry in the source directory @@ -7238,11 +7171,6 @@ package body Prj.Nmsc is or else Is_Regular_File (Display_Source_Directory & Name (1 .. Last)) then - if Current_Verbosity = High then - Write_Str (" Checking "); - Write_Line (Name (1 .. Last)); - end if; - Name_Len := Last; Name_Buffer (1 .. Name_Len) := Name (1 .. Last); Display_File_Name := Name_Find; @@ -7291,12 +7219,9 @@ package body Prj.Nmsc is Excluded_Sources_Htable.Set (Project.Excluded, File_Name, FF); - if Current_Verbosity = High then - Write_Str (" excluded source """); - Write_Str - (Get_Name_String (Display_File_Name)); - Write_Line (""""); - end if; + Debug_Output + ("Excluded source ", + Name_Id (Display_File_Name)); -- Will mark the file as removed, but we -- still need to add it to the list: if we @@ -7327,9 +7252,15 @@ package body Prj.Nmsc is Display_File_Name => Display_File_Name, For_All_Sources => For_All_Sources); end; + + else + if Current_Verbosity = High then + Debug_Output ("Ignore " & Name (1 .. Last)); + end if; end if; end loop; + Debug_Decrease_Indent; Close (Dir); end; end if; @@ -7343,9 +7274,7 @@ package body Prj.Nmsc is Src_Dir_Rank := Num_Nod.Next; end loop; - if Current_Verbosity = High then - Write_Line ("end Looking for sources."); - end if; + Debug_Decrease_Indent ("end Looking for sources."); end Search_Directories; ---------------------------- @@ -7377,11 +7306,9 @@ package body Prj.Nmsc is No_Location, Project.Project); end if; - if Current_Verbosity = High then - Write_Str ("Naming exception: Putting source file "); - Write_Str (Get_Name_String (Source.File)); - Write_Line (" in Source_Names"); - end if; + Debug_Output + ("Naming exception: adding source file to source_Names: ", + Name_Id (Source.File)); Source_Names_Htable.Set (Project.Source_Names, @@ -7568,6 +7495,7 @@ package body Prj.Nmsc is Source.In_Interfaces := False; if Current_Verbosity = High then + Debug_Indent; Write_Str ("Removing file "); Write_Line (Get_Name_String (Excluded.File) @@ -7875,6 +7803,7 @@ package body Prj.Nmsc is begin if Current_Verbosity = High then + Debug_Indent; Write_Str ("Removing source "); Write_Str (Get_Name_String (Id.File)); @@ -7978,7 +7907,7 @@ package body Prj.Nmsc is Element : String_Element; begin - Write_Line ("Source_Dirs:"); + Debug_Increase_Indent ("Source_Dirs:"); Current := Project.Source_Dirs; while Current /= Nil_String loop @@ -7988,7 +7917,7 @@ package body Prj.Nmsc is Current := Element.Next; end loop; - Write_Line ("end Source_Dirs."); + Debug_Decrease_Indent ("end Source_Dirs."); end Show_Source_Dirs; --------------------------- diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb index 3219e68af3a..385ba1d3351 100644 --- a/gcc/ada/prj-part.adb +++ b/gcc/ada/prj-part.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1308,10 +1308,7 @@ package body Prj.Part is end if; if Current_Verbosity >= Medium then - Write_Str ("Parsing """); - Write_Str (Path_Name); - Write_Char ('"'); - Write_Eol; + Debug_Increase_Indent ("Parsing """ & Path_Name & '"'); end if; Project_Directory := @@ -1882,6 +1879,8 @@ package body Prj.Part is -- And restore the comment state that was saved Tree.Restore_And_Free (Project_Comment_State); + + Debug_Decrease_Indent ("Done parsing project"); end Parse_Single_Project; ----------------------- @@ -1899,9 +1898,7 @@ package body Prj.Part is begin if Current_Verbosity = High then - Write_Str ("Project_Name_From ("""); - Write_Str (Canonical); - Write_Line (""")"); + Debug_Output ("Project_Name_From (""" & Canonical & """)"); end if; -- If the path name is empty, return No_Name to indicate failure diff --git a/gcc/ada/prj-pp.adb b/gcc/ada/prj-pp.adb index e03146ce4a6..4a8680e77cf 100644 --- a/gcc/ada/prj-pp.adb +++ b/gcc/ada/prj-pp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -373,6 +373,22 @@ package body Prj.PP is Print (First_Comment_Before (Node, In_Tree), Indent); Start_Line (Indent); + + case Project_Qualifier_Of (Node, In_Tree) is + when Unspecified | Standard => + null; + when Aggregate => + Write_String ("aggregate ", Indent); + when Aggregate_Library => + Write_String ("aggregate library ", Indent); + when Library => + Write_String ("library ", Indent); + when Configuration => + Write_String ("configuration ", Indent); + when Dry => + Write_String ("abstract ", Indent); + end case; + Write_String ("project ", Indent); if Id /= Prj.No_Project then diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index 2ad07b13e1e..0b9d4ff932a 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -48,6 +48,9 @@ package body Prj is The_Empty_String : Name_Id := No_Name; + Debug_Level : Integer := 0; + -- Current indentation level for debug traces. + type Cst_String_Access is access constant String; All_Lower_Case_Image : aliased constant String := "lowercase"; @@ -1300,6 +1303,77 @@ package body Prj is return Count; end Length; + ------------------ + -- Debug_Output -- + ------------------ + + procedure Debug_Output (Str : String) is + begin + if Current_Verbosity > Default then + Write_Line ((1 .. Debug_Level * 2 => ' ') & Str); + end if; + end Debug_Output; + + ------------------ + -- Debug_Indent -- + ------------------ + + procedure Debug_Indent is + begin + if Current_Verbosity = High then + Write_Str ((1 .. Debug_Level * 2 => ' ')); + end if; + end Debug_Indent; + + ------------------ + -- Debug_Output -- + ------------------ + + procedure Debug_Output (Str : String; Str2 : Name_Id) is + begin + if Current_Verbosity = High then + Debug_Indent; + Write_Str (Str); + + if Str2 = No_Name then + Write_Line (" "); + else + Write_Line (" """ & Get_Name_String (Str2) & '"'); + end if; + end if; + end Debug_Output; + + --------------------------- + -- Debug_Increase_Indent -- + --------------------------- + + procedure Debug_Increase_Indent + (Str : String := ""; Str2 : Name_Id := No_Name) + is + begin + if Str2 /= No_Name then + Debug_Output (Str, Str2); + else + Debug_Output (Str); + end if; + Debug_Level := Debug_Level + 1; + end Debug_Increase_Indent; + + --------------------------- + -- Debug_Decrease_Indent -- + --------------------------- + + procedure Debug_Decrease_Indent (Str : String := "") is + begin + if Debug_Level > 0 then + Debug_Level := Debug_Level - 1; + end if; + + if Str /= "" then + Debug_Output (Str); + end if; + end Debug_Decrease_Indent; + begin -- Make sure that the standard config and user project file extensions are -- compatible with canonical case file naming. diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index b1e01efbdee..202e70aeca9 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -849,16 +849,6 @@ package Prj is Hash => Hash, Equal => "="); - type Verbosity is (Default, Medium, High); - pragma Ordered (Verbosity); - -- Verbosity when parsing GNAT Project Files - -- Default is default (very quiet, if no errors). - -- Medium is more verbose. - -- High is extremely verbose. - - Current_Verbosity : Verbosity := Default; - -- The current value of the verbosity the project files are parsed with - type Lib_Kind is (Static, Dynamic, Relocatable); type Policy is (Autonomous, Compliant, Controlled, Restricted, Direct); @@ -1594,6 +1584,35 @@ package Prj is -- The prefix for virtual extending projects. Because of the '$', which is -- normally forbidden for project names, there cannot be any name clash. + ----------- + -- Debug -- + ----------- + + type Verbosity is (Default, Medium, High); + pragma Ordered (Verbosity); + -- Verbosity when parsing GNAT Project Files + -- Default is default (very quiet, if no errors). + -- Medium is more verbose. + -- High is extremely verbose. + + Current_Verbosity : Verbosity := Default; + -- The current value of the verbosity the project files are parsed with + + procedure Debug_Indent; + -- Inserts a series of blanks depending on the current indentation level + + procedure Debug_Output (Str : String); + procedure Debug_Output (Str : String; Str2 : Name_Id); + -- If Current_Verbosity is not Default, outputs Str. + -- This indents Str based on the current indentation level for traces + -- Debug_Error is intended to be used to report an error in the traces. + + procedure Debug_Increase_Indent + (Str : String := ""; Str2 : Name_Id := No_Name); + procedure Debug_Decrease_Indent (Str : String := ""); + -- Increase or decrease the indentation level for debug traces. + -- This indentation level only affects output done through Debug_Output. + private All_Packages : constant String_List_Access := null; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 83c4e0a968d..297f51e0606 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -7226,14 +7226,18 @@ package body Sem_Ch3 is Analyze (N); -- Derivation of subprograms must be delayed until the full subtype - -- has been established to ensure proper overriding of subprograms + -- has been established, to ensure proper overriding of subprograms -- inherited by full types. If the derivations occurred as part of -- the call to Build_Derived_Type above, then the check for type -- conformance would fail because earlier primitive subprograms -- could still refer to the full type prior the change to the new -- subtype and hence would not match the new base type created here. + -- Subprograms are not derived, however, when Derive_Subps is False + -- (since otherwise there could be redundant derivations). - Derive_Subprograms (Parent_Type, Derived_Type); + if Derive_Subps then + Derive_Subprograms (Parent_Type, Derived_Type); + end if; -- For tagged types the Discriminant_Constraint of the new base itype -- is inherited from the first subtype so that no subtype conformance