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

[multiple changes] 

2010-06-21  Robert Dewar  <dewar@adacore.com>

	* exp_ch4.adb (Expand_N_Conditional_Expression): Fold if condition
	known at compile time.

2010-06-21  Gary Dismukes  <dismukes@adacore.com>

	* atree.adb: Fix comment typo.

2010-06-21  Ed Schonberg  <schonberg@adacore.com>

	* sem_eval.adb (Test_Ambiguous_Operator): New procedure to check
	whether a universal arithmetic expression in a conversion, which is
	rewritten from a function call with an expanded name, is ambiguous.

2010-06-21  Vincent Celier  <celier@adacore.com>

	* prj-nmsc.adb (Name_Location): New Boolean component Listed, to record
	source files in specified list of sources.
	(Check_Package_Naming): Remove out parameters Bodies and Specs, as they
	are never used.
	(Add_Source): Set the Location of the new source
	(Process_Exceptions_File_Based): Call Add_Source with the Location
	(Get_Sources_From_File): If an exception is found, set its Listed to
	True
	(Find_Sources): When Source_Files is specified, if an exception is
	found, set its Listed to True. Remove any exception that is not in a
	specified list of sources.
	* prj.ads (Source_Data): New component Location

2010-06-21  Vincent Celier  <celier@adacore.com>

	* gnatbind.adb (Closure_Sources): Global table, moved from block.

From-SVN: r161088
This commit is contained in:
Arnaud Charlet 2010-06-21 17:24:03 +02:00
parent 06f2efd7ed
commit 602a7ec025
7 changed files with 261 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
gcc/ada/ChangeLog
View File

@ -1,3 +1,37 @@
2010-06-21 Robert Dewar <dewar@adacore.com>
* exp_ch4.adb (Expand_N_Conditional_Expression): Fold if condition
known at compile time.
2010-06-21 Gary Dismukes <dismukes@adacore.com>
* atree.adb: Fix comment typo.
2010-06-21 Ed Schonberg <schonberg@adacore.com>
* sem_eval.adb (Test_Ambiguous_Operator): New procedure to check
whether a universal arithmetic expression in a conversion, which is
rewritten from a function call with an expanded name, is ambiguous.
2010-06-21 Vincent Celier <celier@adacore.com>
* prj-nmsc.adb (Name_Location): New Boolean component Listed, to record
source files in specified list of sources.
(Check_Package_Naming): Remove out parameters Bodies and Specs, as they
are never used.
(Add_Source): Set the Location of the new source
(Process_Exceptions_File_Based): Call Add_Source with the Location
(Get_Sources_From_File): If an exception is found, set its Listed to
True
(Find_Sources): When Source_Files is specified, if an exception is
found, set its Listed to True. Remove any exception that is not in a
specified list of sources.
* prj.ads (Source_Data): New component Location
2010-06-21 Vincent Celier <celier@adacore.com>
* gnatbind.adb (Closure_Sources): Global table, moved from block.
2010-06-21 Thomas Quinot <quinot@adacore.com>
* sem_res.adb: Minor reformatting.

2
gcc/ada/atree.adb
View File

@ -108,7 +108,7 @@ package body Atree is
-- calls Rewrite_Breakpoint. Otherwise, does nothing.
procedure Node_Debug_Output (Op : String; N : Node_Id);
-- Common code for nnr and rrd. Write Op followed by information about N
-- Common code for nnd and rrd. Write Op followed by information about N.
-----------------------------
-- Local Objects and Types --

47
gcc/ada/exp_ch4.adb
View File

@ -2826,9 +2826,9 @@ package body Exp_Ch4 is
Insert_Actions (Cnode, Actions, Suppress => All_Checks);
-- Now we construct an array object with appropriate bounds
-- The target is marked as internal, to prevent useless initialization
-- when Initialize_Scalars is enabled.
-- Now we construct an array object with appropriate bounds. We mark
-- the target as internal to prevent useless initialization when
-- Initialize_Scalars is enabled.
Ent := Make_Temporary (Loc, 'S');
Set_Is_Internal (Ent);
@ -4025,13 +4025,44 @@ package body Exp_Ch4 is
Elsex : constant Node_Id := Next (Thenx);
Typ : constant Entity_Id := Etype (N);
Cnn : Entity_Id;
Decl : Node_Id;
New_If : Node_Id;
New_N : Node_Id;
P_Decl : Node_Id;
Cnn : Entity_Id;
Decl : Node_Id;
New_If : Node_Id;
New_N : Node_Id;
P_Decl : Node_Id;
Expr : Node_Id;
Actions : List_Id;
begin
-- Fold at compile time if condition known. We have already folded
-- static conditional expressions, but it is possible to fold any
-- case in which the condition is known at compile time, even though
-- the result is non-static.
-- Note that we don't do the fold of such cases in Sem_Elab because
-- it can cause infinite loops with the expander adding a conditional
-- expression, and Sem_Elab circuitry removing it repeatedly.
if Compile_Time_Known_Value (Cond) then
if Is_True (Expr_Value (Cond)) then
Expr := Thenx;
Actions := Then_Actions (N);
else
Expr := Elsex;
Actions := Else_Actions (N);
end if;
Remove (Expr);
Insert_Actions (N, Actions);
Rewrite (N, Relocate_Node (Expr));
-- Note that the result is never static (legitimate cases of static
-- conditional expressions were folded in Sem_Eval).
Set_Is_Static_Expression (N, False);
return;
end if;
-- If the type is limited or unconstrained, we expand as follows to
-- avoid any possibility of improper copies.

28
gcc/ada/gnatbind.adb
View File

@ -82,6 +82,16 @@ procedure Gnatbind is
Mapping_File : String_Ptr := null;
package Closure_Sources is new Table.Table
(Table_Component_Type => File_Name_Type,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Gnatbind.Closure_Sources");
-- Table to record the sources in the closure, to avoid duplications. Used
-- only with switch -R.
function Gnatbind_Supports_Auto_Init return Boolean;
-- Indicates if automatic initialization of elaboration procedure
-- through the constructor mechanism is possible on the platform.
@ -817,16 +827,6 @@ begin
if List_Closure then
declare
package Sources is new Table.Table
(Table_Component_Type => File_Name_Type,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Gnatbind.Sources");
-- Table to record the sources in the closure, to avoid
-- dupications.
Source : File_Name_Type;
function Put_In_Sources (S : File_Name_Type) return Boolean;
@ -842,17 +842,19 @@ begin
return Boolean
is
begin
for J in 1 .. Sources.Last loop
if Sources.Table (J) = S then
for J in 1 .. Closure_Sources.Last loop
if Closure_Sources.Table (J) = S then
return False;
end if;
end loop;
Sources.Append (S);
Closure_Sources.Append (S);
return True;
end Put_In_Sources;
begin
Closure_Sources.Init;
if not Zero_Formatting then
Write_Eol;
Write_Str ("REFERENCED SOURCES");

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

@ -54,10 +54,11 @@ package body Prj.Nmsc is
Name : File_Name_Type; -- ??? duplicates the key
Location : Source_Ptr;
Source : Source_Id := No_Source;
Listed : Boolean := False;
Found : Boolean := False;
end record;
No_Name_Location : constant Name_Location :=
(No_File, No_Location, No_Source, False);
(No_File, No_Location, No_Source, False, False);
package Source_Names_Htable is new GNAT.Dynamic_HTables.Simple_HTable
(Header_Num => Header_Num,
Element => Name_Location,
@ -234,13 +235,9 @@ package body Prj.Nmsc is
procedure Check_Package_Naming
(Project : Project_Id;
Data : in out Tree_Processing_Data;
Bodies : out Array_Element_Id;
Specs : out Array_Element_Id);
Data : in out Tree_Processing_Data);
-- Check the naming scheme part of Data, and initialize the naming scheme
-- data in the config of the various languages. This also returns the
-- naming scheme exceptions for unit-based languages (Bodies and Specs are
-- associative arrays mapping individual unit names to source file names).
-- data in the config of the various languages.
procedure Check_Configuration
(Project : Project_Id;
@ -727,6 +724,7 @@ package body Prj.Nmsc is
end if;
Id.Project := Project;
Id.Location := Location;
Id.Source_Dir_Rank := Source_Dir_Rank;
Id.Language := Lang_Id;
Id.Kind := Kind;
@ -816,8 +814,6 @@ package body Prj.Nmsc is
(Project : Project_Id;
Data : in out Tree_Processing_Data)
is
Specs : Array_Element_Id;
Bodies : Array_Element_Id;
Extending : Boolean := False;
Prj_Data : Project_Processing_Data;
@ -889,7 +885,7 @@ package body Prj.Nmsc is
Extending := Project.Extends /= No_Project;
Check_Package_Naming (Project, Data, Bodies => Bodies, Specs => Specs);
Check_Package_Naming (Project, Data);
-- Find the sources
@ -2722,9 +2718,7 @@ package body Prj.Nmsc is
procedure Check_Package_Naming
(Project : Project_Id;
Data : in out Tree_Processing_Data;
Bodies : out Array_Element_Id;
Specs : out Array_Element_Id)
Data : in out Tree_Processing_Data)
is
Naming_Id : constant Package_Id :=
Util.Value_Of
@ -2957,7 +2951,8 @@ package body Prj.Nmsc is
Kind => Kind,
File_Name => File_Name,
Display_File => File_Name_Type (Element.Value),
Naming_Exception => True);
Naming_Exception => True,
Location => Element.Location);
else
-- Check if the file name is already recorded for another
@ -3380,9 +3375,6 @@ package body Prj.Nmsc is
-- Start of processing for Check_Naming_Schemes
begin
Specs := No_Array_Element;
Bodies := No_Array_Element;
-- No Naming package or parsing a configuration file? nothing to do
if Naming_Id /= No_Package
@ -5557,7 +5549,11 @@ package body Prj.Nmsc is
(Name => Source_Name,
Location => Location,
Source => No_Source,
Listed => True,
Found => False);
else
Name_Loc.Listed := True;
end if;
Source_Names_Htable.Set
@ -6292,11 +6288,16 @@ package body Prj.Nmsc is
(Name => Name,
Location => Location,
Source => No_Source,
Listed => True,
Found => False);
Source_Names_Htable.Set
(Project.Source_Names, Name, Name_Loc);
else
Name_Loc.Listed := True;
end if;
Source_Names_Htable.Set
(Project.Source_Names, Name, Name_Loc);
Current := Element.Next;
end loop;
@ -6343,6 +6344,57 @@ package body Prj.Nmsc is
Has_Explicit_Sources := False;
end if;
-- Remove any exception that is not in the specified list of sources
if Has_Explicit_Sources then
declare
Source : Source_Id;
Iter : Source_Iterator;
NL : Name_Location;
Again : Boolean;
begin
Iter_Loop :
loop
Again := False;
Iter := For_Each_Source (Data.Tree, Project.Project);
Source_Loop :
loop
Source := Prj.Element (Iter);
exit Source_Loop when Source = No_Source;
if Source.Naming_Exception then
NL := Source_Names_Htable.Get
(Project.Source_Names, Source.File);
if NL /= No_Name_Location and then not NL.Listed then
-- Remove the exception
Source_Names_Htable.Set
(Project.Source_Names,
Source.File,
No_Name_Location);
Remove_Source (Source, No_Source);
Error_Msg_Name_1 := Name_Id (Source.File);
Error_Msg
(Data.Flags,
"? unknown source file %%",
NL.Location,
Project.Project);
Again := True;
exit Source_Loop;
end if;
end if;
Next (Iter);
end loop Source_Loop;
exit Iter_Loop when not Again;
end loop Iter_Loop;
end;
end if;
Search_Directories
(Project,
Data => Data,
@ -7031,8 +7083,9 @@ package body Prj.Nmsc is
K => Source.File,
E => Name_Location'
(Name => Source.File,
Location => No_Location,
Location => Source.Location,
Source => Source,
Listed => False,
Found => False));
-- If this is an Ada exception, record in table Unit_Exceptions

5
gcc/ada/prj.ads
View File

@ -667,6 +667,10 @@ package Prj is
Project : Project_Id := No_Project;
-- Project of the source
Location : Source_Ptr := No_Location;
-- Location in the project file of the declaration of the source in
-- package Naming.
Source_Dir_Rank : Natural := 0;
-- The rank of the source directory in list declared with attribute
-- Source_Dirs. Two source files with the same name cannot appears in
@ -768,6 +772,7 @@ package Prj is
No_Source_Data : constant Source_Data :=
(Project => No_Project,
Location => No_Location,
Source_Dir_Rank => 0,
Language => No_Language_Index,
In_Interfaces => True,

94
gcc/ada/sem_eval.adb
View File

@ -180,6 +180,13 @@ package body Sem_Eval is
-- used for producing the result of the static evaluation of the
-- logical operators
procedure Test_Ambiguous_Operator (N : Node_Id);
-- Check whether an arithmetic operation with universal operands which
-- is a rewritten function call with an explicit scope indication is
-- ambiguous: P."+" (1, 2) will be ambiguous if there is more than one
-- visible numeric type declared in P and the context does not impose a
-- type on the result (e.g. in the expression of a type conversion).
procedure Test_Expression_Is_Foldable
(N : Node_Id;
Op1 : Node_Id;
@ -1458,6 +1465,15 @@ package body Sem_Eval is
return;
end if;
if (Etype (Right) = Universal_Integer
or else Etype (Right) = Universal_Real)
and then
(Etype (Left) = Universal_Integer
or else Etype (Left) = Universal_Real)
then
Test_Ambiguous_Operator (N);
end if;
-- Fold for cases where both operands are of integer type
if Is_Integer_Type (Ltype) and then Is_Integer_Type (Rtype) then
@ -3395,6 +3411,12 @@ package body Sem_Eval is
return;
end if;
if Etype (Right) = Universal_Integer
or else Etype (Right) = Universal_Real
then
Test_Ambiguous_Operator (N);
end if;
-- Fold for integer case
if Is_Integer_Type (Etype (N)) then
@ -4699,6 +4721,78 @@ package body Sem_Eval is
end if;
end Test;
-----------------------------
-- Test_Ambiguous_Operator --
-----------------------------
procedure Test_Ambiguous_Operator (N : Node_Id) is
Call : constant Node_Id := Original_Node (N);
Is_Int : constant Boolean := Is_Integer_Type (Etype (N));
Is_Fix : constant Boolean :=
Nkind (N) in N_Binary_Op
and then Nkind (Right_Opnd (N)) /= Nkind (Left_Opnd (N));
-- a mixed-mode operation in this context indicates the
-- presence of fixed-point type in the designated package.
E : Entity_Id;
Pack : Entity_Id;
Typ1 : Entity_Id;
Priv_E : Entity_Id;
begin
if Nkind (Call) /= N_Function_Call
or else Nkind (Name (Call)) /= N_Expanded_Name
then
return;
elsif Nkind (Parent (N)) = N_Type_Conversion then
Pack := Entity (Prefix (Name (Call)));
-- If the prefix is a package declared elsewhere, iterate over
-- its visible entities, otherwise iterate over all declarations
-- in the designated scope.
if Ekind (Pack) = E_Package
and then not In_Open_Scopes (Pack)
then
Priv_E := First_Private_Entity (Pack);
else
Priv_E := Empty;
end if;
Typ1 := Empty;
E := First_Entity (Pack);
while Present (E)
and then E /= Priv_E
loop
if Is_Numeric_Type (E)
and then Nkind (Parent (E)) /= N_Subtype_Declaration
and then Comes_From_Source (E)
and then Is_Integer_Type (E) = Is_Int
and then
(Nkind (N) in N_Unary_Op
or else Is_Fixed_Point_Type (E) = Is_Fix)
then
if No (Typ1) then
Typ1 := E;
else
-- More than one type of the proper class declared in P
Error_Msg_N ("ambiguous operation", N);
Error_Msg_Sloc := Sloc (Typ1);
Error_Msg_N ("\possible interpretation (inherited)#", N);
Error_Msg_Sloc := Sloc (E);
Error_Msg_N ("\possible interpretation (inherited)#", N);
end if;
end if;
Next_Entity (E);
end loop;
end if;
end Test_Ambiguous_Operator;
---------------------------------
-- Test_Expression_Is_Foldable --
---------------------------------