Skip to content

R
riscv-gcc-1
Commit 3e582869 by Arnaud Charlet
Options

[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
parent 56e94186
Showing with 245 additions and 92 deletions
gcc/ada/ChangeLog
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> 2011-08-03 Eric Botcazou <ebotcazou@adacore.com>
* gnat_ugn.texi: Document -Wstack-usage. * gnat_ugn.texi: Document -Wstack-usage.
......
gcc/ada/exp_aggr.adb
...@@ -1854,6 +1854,11 @@ package body Exp_Aggr is ...@@ -1854,6 +1854,11 @@ package body Exp_Aggr is
-- to finalization list F. Init_Pr conditions the call to the init proc -- to finalization list F. Init_Pr conditions the call to the init proc
-- since it may already be done due to ancestor initialization. -- 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; function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean;
-- Check whether Bounds is a range node and its lower and higher bounds -- Check whether Bounds is a range node and its lower and higher bounds
-- are integers literals. -- are integers literals.
...@@ -2156,6 +2161,56 @@ package body Exp_Aggr is ...@@ -2156,6 +2161,56 @@ package body Exp_Aggr is
return L; return L;
end Init_Controller; 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 -- -- Is_Int_Range_Bounds --
------------------------- -------------------------
...@@ -2741,6 +2796,17 @@ package body Exp_Aggr is ...@@ -2741,6 +2796,17 @@ package body Exp_Aggr is
end if; end if;
end; 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) -- Normal case (not an extension aggregate)
else else
...@@ -2752,59 +2818,7 @@ package body Exp_Aggr is ...@@ -2752,59 +2818,7 @@ package body Exp_Aggr is
if Has_Discriminants (Typ) if Has_Discriminants (Typ)
and then not Is_Unchecked_Union (Base_Type (Typ)) and then not Is_Unchecked_Union (Base_Type (Typ))
then then
-- If the type is derived, and constrains discriminants of the Init_Hidden_Discriminants (Typ, L);
-- 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;
-- Generate discriminant init values for the visible discriminants -- Generate discriminant init values for the visible discriminants
......
gcc/ada/prj-env.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -782,13 +782,12 @@ package body Prj.Env is ...@@ -782,13 +782,12 @@ package body Prj.Env is
procedure Put_Name_Buffer is procedure Put_Name_Buffer is
begin begin
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := ASCII.LF;
if Current_Verbosity = High then if Current_Verbosity = High then
Write_Str ("Mapping file: " & Name_Buffer (1 .. Name_Len)); Debug_Output (Name_Buffer (1 .. Name_Len));
end if; end if;
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := ASCII.LF;
Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last); Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
end Put_Name_Buffer; end Put_Name_Buffer;
...@@ -875,6 +874,12 @@ package body Prj.Env is ...@@ -875,6 +874,12 @@ package body Prj.Env is
-- Start of processing for Create_Mapping_File -- Start of processing for Create_Mapping_File
begin 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); For_Every_Imported_Project (Project, Dummy);
declare declare
...@@ -882,8 +887,6 @@ package body Prj.Env is ...@@ -882,8 +887,6 @@ package body Prj.Env is
Status : Boolean := False; Status : Boolean := False;
begin begin
Create_Temp_File (In_Tree, File, Name, "mapping");
if File /= Invalid_FD then if File /= Invalid_FD then
Last := Write (File, Buffer (1)'Address, Buffer_Last); Last := Write (File, Buffer (1)'Address, Buffer_Last);
...@@ -898,6 +901,8 @@ package body Prj.Env is ...@@ -898,6 +901,8 @@ package body Prj.Env is
end; end;
Free (Buffer); Free (Buffer);
Debug_Decrease_Indent ("Done create mapping file");
end Create_Mapping_File; end Create_Mapping_File;
---------------------- ----------------------
...@@ -2021,8 +2026,7 @@ package body Prj.Env is ...@@ -2021,8 +2026,7 @@ package body Prj.Env is
begin begin
if Current_Verbosity = High then if Current_Verbosity = High then
Write_Str (" Trying "); Debug_Output ("Trying " & Path);
Write_Line (Path);
end if; end if;
if Is_Absolute_Path (Path) then if Is_Absolute_Path (Path) then
...@@ -2064,8 +2068,7 @@ package body Prj.Env is ...@@ -2064,8 +2068,7 @@ package body Prj.Env is
Add_Str_To_Name_Buffer (Path); Add_Str_To_Name_Buffer (Path);
if Current_Verbosity = High then if Current_Verbosity = High then
Write_Str (" Testing file "); Debug_Output ("Testing file " & Name_Buffer (1 .. Name_Len));
Write_Line (Name_Buffer (1 .. Name_Len));
end if; end if;
if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then
...@@ -2092,11 +2095,9 @@ package body Prj.Env is ...@@ -2092,11 +2095,9 @@ package body Prj.Env is
Initialize_Project_Path (Self, Target_Name); Initialize_Project_Path (Self, Target_Name);
if Current_Verbosity = High then if Current_Verbosity = High then
Write_Str ("Searching for project ("""); Debug_Increase_Indent
Write_Str (File); ("Searching for project """ & File & """ in """
Write_Str (""", """); & Directory & '"');
Write_Str (Directory);
Write_Line (""");");
end if; end if;
-- Check the project cache -- Check the project cache
...@@ -2107,6 +2108,7 @@ package body Prj.Env is ...@@ -2107,6 +2108,7 @@ package body Prj.Env is
Path := Projects_Paths.Get (Self.Cache, Key); Path := Projects_Paths.Get (Self.Cache, Key);
if Path /= No_Path then if Path /= No_Path then
Debug_Decrease_Indent;
return; return;
end if; end if;
...@@ -2176,6 +2178,8 @@ package body Prj.Env is ...@@ -2176,6 +2178,8 @@ package body Prj.Env is
Projects_Paths.Set (Self.Cache, Key, Path); Projects_Paths.Set (Self.Cache, Key, Path);
end; end;
end if; end if;
Debug_Decrease_Indent;
end Find_Project; end Find_Project;
---------- ----------
......
gcc/ada/prj-part.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -1308,10 +1308,7 @@ package body Prj.Part is ...@@ -1308,10 +1308,7 @@ package body Prj.Part is
end if; end if;
if Current_Verbosity >= Medium then if Current_Verbosity >= Medium then
Write_Str ("Parsing """); Debug_Increase_Indent ("Parsing """ & Path_Name & '"');
Write_Str (Path_Name);
Write_Char ('"');
Write_Eol;
end if; end if;
Project_Directory := Project_Directory :=
...@@ -1882,6 +1879,8 @@ package body Prj.Part is ...@@ -1882,6 +1879,8 @@ package body Prj.Part is
-- And restore the comment state that was saved -- And restore the comment state that was saved
Tree.Restore_And_Free (Project_Comment_State); Tree.Restore_And_Free (Project_Comment_State);
Debug_Decrease_Indent ("Done parsing project");
end Parse_Single_Project; end Parse_Single_Project;
----------------------- -----------------------
...@@ -1899,9 +1898,7 @@ package body Prj.Part is ...@@ -1899,9 +1898,7 @@ package body Prj.Part is
begin begin
if Current_Verbosity = High then if Current_Verbosity = High then
Write_Str ("Project_Name_From ("""); Debug_Output ("Project_Name_From (""" & Canonical & """)");
Write_Str (Canonical);
Write_Line (""")");
end if; end if;
-- If the path name is empty, return No_Name to indicate failure -- If the path name is empty, return No_Name to indicate failure
......
gcc/ada/prj-pp.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -373,6 +373,22 @@ package body Prj.PP is ...@@ -373,6 +373,22 @@ package body Prj.PP is
Print (First_Comment_Before (Node, In_Tree), Indent); Print (First_Comment_Before (Node, In_Tree), Indent);
Start_Line (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); Write_String ("project ", Indent);
if Id /= Prj.No_Project then if Id /= Prj.No_Project then
......
gcc/ada/prj.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -48,6 +48,9 @@ package body Prj is ...@@ -48,6 +48,9 @@ package body Prj is
The_Empty_String : Name_Id := No_Name; 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; type Cst_String_Access is access constant String;
All_Lower_Case_Image : aliased constant String := "lowercase"; All_Lower_Case_Image : aliased constant String := "lowercase";
...@@ -1300,6 +1303,77 @@ package body Prj is ...@@ -1300,6 +1303,77 @@ package body Prj is
return Count; return Count;
end Length; 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 begin
-- Make sure that the standard config and user project file extensions are -- Make sure that the standard config and user project file extensions are
-- compatible with canonical case file naming. -- compatible with canonical case file naming.
......
gcc/ada/prj.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -849,16 +849,6 @@ package Prj is ...@@ -849,16 +849,6 @@ package Prj is
Hash => Hash, Hash => Hash,
Equal => "="); 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 Lib_Kind is (Static, Dynamic, Relocatable);
type Policy is (Autonomous, Compliant, Controlled, Restricted, Direct); type Policy is (Autonomous, Compliant, Controlled, Restricted, Direct);
...@@ -1594,6 +1584,35 @@ package Prj is ...@@ -1594,6 +1584,35 @@ package Prj is
-- The prefix for virtual extending projects. Because of the '$', which is -- The prefix for virtual extending projects. Because of the '$', which is
-- normally forbidden for project names, there cannot be any name clash. -- 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 private
All_Packages : constant String_List_Access := null; All_Packages : constant String_List_Access := null;
......
gcc/ada/sem_ch3.adb
...@@ -7226,14 +7226,18 @@ package body Sem_Ch3 is ...@@ -7226,14 +7226,18 @@ package body Sem_Ch3 is
Analyze (N); Analyze (N);
-- Derivation of subprograms must be delayed until the full subtype -- 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 -- inherited by full types. If the derivations occurred as part of
-- the call to Build_Derived_Type above, then the check for type -- the call to Build_Derived_Type above, then the check for type
-- conformance would fail because earlier primitive subprograms -- conformance would fail because earlier primitive subprograms
-- could still refer to the full type prior the change to the new -- 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. -- 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 -- For tagged types the Discriminant_Constraint of the new base itype
-- is inherited from the first subtype so that no subtype conformance -- is inherited from the first subtype so that no subtype conformance
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment