OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

2011-08-03  Gary Dismukes  <dismukes@adacore.com>

	* 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  <miranda@adacore.com>

	* 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  <briot@adacore.com>

	* prj-pp.adb (Print): also output project qualifiers, since in
	particular "aggregate" is mandatory in an aggregate project.

2011-08-03  Emmanuel Briot  <briot@adacore.com>

	* prj-part.adb, prj.adb, prj.ads, prj-nmsc.adb, prj-env.adb:
	(Debug_Output): new function.

From-SVN: r177240
This commit is contained in:
Arnaud Charlet 2011-08-03 10:26:17 +02:00
parent 56e941863b
commit 3e5828693d
9 changed files with 352 additions and 270 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
gcc/ada/ChangeLog
View File

@ -1,3 +1,28 @@
2011-08-03 Gary Dismukes <dismukes@adacore.com>
* 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 <miranda@adacore.com>
* 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 <briot@adacore.com>
* prj-pp.adb (Print): also output project qualifiers, since in
particular "aggregate" is mandatory in an aggregate project.
2011-08-03 Emmanuel Briot <briot@adacore.com>
* prj-part.adb, prj.adb, prj.ads, prj-nmsc.adb, prj-env.adb:
(Debug_Output): new function.
2011-08-03 Eric Botcazou <ebotcazou@adacore.com>
* gnat_ugn.texi: Document -Wstack-usage.

120
gcc/ada/exp_aggr.adb
View File

@ -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

36
gcc/ada/prj-env.adb
View File

@ -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;
----------

285
gcc/ada/prj-nmsc.adb
View File

@ -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;
---------------------------

13
gcc/ada/prj-part.adb
View File

@ -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

18
gcc/ada/prj-pp.adb
View File

@ -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

76
gcc/ada/prj.adb
View File

@ -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 (" <no_name>");
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.

41
gcc/ada/prj.ads
View File

@ -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;

8
gcc/ada/sem_ch3.adb
View File

@ -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