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>
* gnat_ugn.texi: Document -Wstack-usage.
......
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
......
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;
----------
......
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
......
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
......
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 (" <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.
......
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;
......
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
......
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