[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:
parent
06f2efd7ed
commit
602a7ec025
|
@ -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>
|
2010-06-21 Thomas Quinot <quinot@adacore.com>
|
||||||
|
|
||||||
* sem_res.adb: Minor reformatting.
|
* sem_res.adb: Minor reformatting.
|
||||||
|
|
|
@ -108,7 +108,7 @@ package body Atree is
|
||||||
-- calls Rewrite_Breakpoint. Otherwise, does nothing.
|
-- calls Rewrite_Breakpoint. Otherwise, does nothing.
|
||||||
|
|
||||||
procedure Node_Debug_Output (Op : String; N : Node_Id);
|
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 --
|
-- Local Objects and Types --
|
||||||
|
|
|
@ -2826,9 +2826,9 @@ package body Exp_Ch4 is
|
||||||
|
|
||||||
Insert_Actions (Cnode, Actions, Suppress => All_Checks);
|
Insert_Actions (Cnode, Actions, Suppress => All_Checks);
|
||||||
|
|
||||||
-- Now we construct an array object with appropriate bounds
|
-- Now we construct an array object with appropriate bounds. We mark
|
||||||
-- The target is marked as internal, to prevent useless initialization
|
-- the target as internal to prevent useless initialization when
|
||||||
-- when Initialize_Scalars is enabled.
|
-- Initialize_Scalars is enabled.
|
||||||
|
|
||||||
Ent := Make_Temporary (Loc, 'S');
|
Ent := Make_Temporary (Loc, 'S');
|
||||||
Set_Is_Internal (Ent);
|
Set_Is_Internal (Ent);
|
||||||
|
@ -4025,13 +4025,44 @@ package body Exp_Ch4 is
|
||||||
Elsex : constant Node_Id := Next (Thenx);
|
Elsex : constant Node_Id := Next (Thenx);
|
||||||
Typ : constant Entity_Id := Etype (N);
|
Typ : constant Entity_Id := Etype (N);
|
||||||
|
|
||||||
Cnn : Entity_Id;
|
Cnn : Entity_Id;
|
||||||
Decl : Node_Id;
|
Decl : Node_Id;
|
||||||
New_If : Node_Id;
|
New_If : Node_Id;
|
||||||
New_N : Node_Id;
|
New_N : Node_Id;
|
||||||
P_Decl : Node_Id;
|
P_Decl : Node_Id;
|
||||||
|
Expr : Node_Id;
|
||||||
|
Actions : List_Id;
|
||||||
|
|
||||||
begin
|
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
|
-- If the type is limited or unconstrained, we expand as follows to
|
||||||
-- avoid any possibility of improper copies.
|
-- avoid any possibility of improper copies.
|
||||||
|
|
||||||
|
|
|
@ -82,6 +82,16 @@ procedure Gnatbind is
|
||||||
|
|
||||||
Mapping_File : String_Ptr := null;
|
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;
|
function Gnatbind_Supports_Auto_Init return Boolean;
|
||||||
-- Indicates if automatic initialization of elaboration procedure
|
-- Indicates if automatic initialization of elaboration procedure
|
||||||
-- through the constructor mechanism is possible on the platform.
|
-- through the constructor mechanism is possible on the platform.
|
||||||
|
@ -817,16 +827,6 @@ begin
|
||||||
|
|
||||||
if List_Closure then
|
if List_Closure then
|
||||||
declare
|
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;
|
Source : File_Name_Type;
|
||||||
|
|
||||||
function Put_In_Sources (S : File_Name_Type) return Boolean;
|
function Put_In_Sources (S : File_Name_Type) return Boolean;
|
||||||
|
@ -842,17 +842,19 @@ begin
|
||||||
return Boolean
|
return Boolean
|
||||||
is
|
is
|
||||||
begin
|
begin
|
||||||
for J in 1 .. Sources.Last loop
|
for J in 1 .. Closure_Sources.Last loop
|
||||||
if Sources.Table (J) = S then
|
if Closure_Sources.Table (J) = S then
|
||||||
return False;
|
return False;
|
||||||
end if;
|
end if;
|
||||||
end loop;
|
end loop;
|
||||||
|
|
||||||
Sources.Append (S);
|
Closure_Sources.Append (S);
|
||||||
return True;
|
return True;
|
||||||
end Put_In_Sources;
|
end Put_In_Sources;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
|
Closure_Sources.Init;
|
||||||
|
|
||||||
if not Zero_Formatting then
|
if not Zero_Formatting then
|
||||||
Write_Eol;
|
Write_Eol;
|
||||||
Write_Str ("REFERENCED SOURCES");
|
Write_Str ("REFERENCED SOURCES");
|
||||||
|
|
|
@ -54,10 +54,11 @@ package body Prj.Nmsc is
|
||||||
Name : File_Name_Type; -- ??? duplicates the key
|
Name : File_Name_Type; -- ??? duplicates the key
|
||||||
Location : Source_Ptr;
|
Location : Source_Ptr;
|
||||||
Source : Source_Id := No_Source;
|
Source : Source_Id := No_Source;
|
||||||
|
Listed : Boolean := False;
|
||||||
Found : Boolean := False;
|
Found : Boolean := False;
|
||||||
end record;
|
end record;
|
||||||
No_Name_Location : constant Name_Location :=
|
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
|
package Source_Names_Htable is new GNAT.Dynamic_HTables.Simple_HTable
|
||||||
(Header_Num => Header_Num,
|
(Header_Num => Header_Num,
|
||||||
Element => Name_Location,
|
Element => Name_Location,
|
||||||
|
@ -234,13 +235,9 @@ package body Prj.Nmsc is
|
||||||
|
|
||||||
procedure Check_Package_Naming
|
procedure Check_Package_Naming
|
||||||
(Project : Project_Id;
|
(Project : Project_Id;
|
||||||
Data : in out Tree_Processing_Data;
|
Data : in out Tree_Processing_Data);
|
||||||
Bodies : out Array_Element_Id;
|
|
||||||
Specs : out Array_Element_Id);
|
|
||||||
-- Check the naming scheme part of Data, and initialize the naming scheme
|
-- Check the naming scheme part of Data, and initialize the naming scheme
|
||||||
-- data in the config of the various languages. This also returns the
|
-- data in the config of the various languages.
|
||||||
-- naming scheme exceptions for unit-based languages (Bodies and Specs are
|
|
||||||
-- associative arrays mapping individual unit names to source file names).
|
|
||||||
|
|
||||||
procedure Check_Configuration
|
procedure Check_Configuration
|
||||||
(Project : Project_Id;
|
(Project : Project_Id;
|
||||||
|
@ -727,6 +724,7 @@ package body Prj.Nmsc is
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
Id.Project := Project;
|
Id.Project := Project;
|
||||||
|
Id.Location := Location;
|
||||||
Id.Source_Dir_Rank := Source_Dir_Rank;
|
Id.Source_Dir_Rank := Source_Dir_Rank;
|
||||||
Id.Language := Lang_Id;
|
Id.Language := Lang_Id;
|
||||||
Id.Kind := Kind;
|
Id.Kind := Kind;
|
||||||
|
@ -816,8 +814,6 @@ package body Prj.Nmsc is
|
||||||
(Project : Project_Id;
|
(Project : Project_Id;
|
||||||
Data : in out Tree_Processing_Data)
|
Data : in out Tree_Processing_Data)
|
||||||
is
|
is
|
||||||
Specs : Array_Element_Id;
|
|
||||||
Bodies : Array_Element_Id;
|
|
||||||
Extending : Boolean := False;
|
Extending : Boolean := False;
|
||||||
Prj_Data : Project_Processing_Data;
|
Prj_Data : Project_Processing_Data;
|
||||||
|
|
||||||
|
@ -889,7 +885,7 @@ package body Prj.Nmsc is
|
||||||
|
|
||||||
Extending := Project.Extends /= No_Project;
|
Extending := Project.Extends /= No_Project;
|
||||||
|
|
||||||
Check_Package_Naming (Project, Data, Bodies => Bodies, Specs => Specs);
|
Check_Package_Naming (Project, Data);
|
||||||
|
|
||||||
-- Find the sources
|
-- Find the sources
|
||||||
|
|
||||||
|
@ -2722,9 +2718,7 @@ package body Prj.Nmsc is
|
||||||
|
|
||||||
procedure Check_Package_Naming
|
procedure Check_Package_Naming
|
||||||
(Project : Project_Id;
|
(Project : Project_Id;
|
||||||
Data : in out Tree_Processing_Data;
|
Data : in out Tree_Processing_Data)
|
||||||
Bodies : out Array_Element_Id;
|
|
||||||
Specs : out Array_Element_Id)
|
|
||||||
is
|
is
|
||||||
Naming_Id : constant Package_Id :=
|
Naming_Id : constant Package_Id :=
|
||||||
Util.Value_Of
|
Util.Value_Of
|
||||||
|
@ -2957,7 +2951,8 @@ package body Prj.Nmsc is
|
||||||
Kind => Kind,
|
Kind => Kind,
|
||||||
File_Name => File_Name,
|
File_Name => File_Name,
|
||||||
Display_File => File_Name_Type (Element.Value),
|
Display_File => File_Name_Type (Element.Value),
|
||||||
Naming_Exception => True);
|
Naming_Exception => True,
|
||||||
|
Location => Element.Location);
|
||||||
|
|
||||||
else
|
else
|
||||||
-- Check if the file name is already recorded for another
|
-- 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
|
-- Start of processing for Check_Naming_Schemes
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Specs := No_Array_Element;
|
|
||||||
Bodies := No_Array_Element;
|
|
||||||
|
|
||||||
-- No Naming package or parsing a configuration file? nothing to do
|
-- No Naming package or parsing a configuration file? nothing to do
|
||||||
|
|
||||||
if Naming_Id /= No_Package
|
if Naming_Id /= No_Package
|
||||||
|
@ -5557,7 +5549,11 @@ package body Prj.Nmsc is
|
||||||
(Name => Source_Name,
|
(Name => Source_Name,
|
||||||
Location => Location,
|
Location => Location,
|
||||||
Source => No_Source,
|
Source => No_Source,
|
||||||
|
Listed => True,
|
||||||
Found => False);
|
Found => False);
|
||||||
|
|
||||||
|
else
|
||||||
|
Name_Loc.Listed := True;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
Source_Names_Htable.Set
|
Source_Names_Htable.Set
|
||||||
|
@ -6292,11 +6288,16 @@ package body Prj.Nmsc is
|
||||||
(Name => Name,
|
(Name => Name,
|
||||||
Location => Location,
|
Location => Location,
|
||||||
Source => No_Source,
|
Source => No_Source,
|
||||||
|
Listed => True,
|
||||||
Found => False);
|
Found => False);
|
||||||
Source_Names_Htable.Set
|
|
||||||
(Project.Source_Names, Name, Name_Loc);
|
else
|
||||||
|
Name_Loc.Listed := True;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
Source_Names_Htable.Set
|
||||||
|
(Project.Source_Names, Name, Name_Loc);
|
||||||
|
|
||||||
Current := Element.Next;
|
Current := Element.Next;
|
||||||
end loop;
|
end loop;
|
||||||
|
|
||||||
|
@ -6343,6 +6344,57 @@ package body Prj.Nmsc is
|
||||||
Has_Explicit_Sources := False;
|
Has_Explicit_Sources := False;
|
||||||
end if;
|
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
|
Search_Directories
|
||||||
(Project,
|
(Project,
|
||||||
Data => Data,
|
Data => Data,
|
||||||
|
@ -7031,8 +7083,9 @@ package body Prj.Nmsc is
|
||||||
K => Source.File,
|
K => Source.File,
|
||||||
E => Name_Location'
|
E => Name_Location'
|
||||||
(Name => Source.File,
|
(Name => Source.File,
|
||||||
Location => No_Location,
|
Location => Source.Location,
|
||||||
Source => Source,
|
Source => Source,
|
||||||
|
Listed => False,
|
||||||
Found => False));
|
Found => False));
|
||||||
|
|
||||||
-- If this is an Ada exception, record in table Unit_Exceptions
|
-- If this is an Ada exception, record in table Unit_Exceptions
|
||||||
|
|
|
@ -667,6 +667,10 @@ package Prj is
|
||||||
Project : Project_Id := No_Project;
|
Project : Project_Id := No_Project;
|
||||||
-- Project of the source
|
-- 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;
|
Source_Dir_Rank : Natural := 0;
|
||||||
-- The rank of the source directory in list declared with attribute
|
-- The rank of the source directory in list declared with attribute
|
||||||
-- Source_Dirs. Two source files with the same name cannot appears in
|
-- 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 :=
|
No_Source_Data : constant Source_Data :=
|
||||||
(Project => No_Project,
|
(Project => No_Project,
|
||||||
|
Location => No_Location,
|
||||||
Source_Dir_Rank => 0,
|
Source_Dir_Rank => 0,
|
||||||
Language => No_Language_Index,
|
Language => No_Language_Index,
|
||||||
In_Interfaces => True,
|
In_Interfaces => True,
|
||||||
|
|
|
@ -180,6 +180,13 @@ package body Sem_Eval is
|
||||||
-- used for producing the result of the static evaluation of the
|
-- used for producing the result of the static evaluation of the
|
||||||
-- logical operators
|
-- 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
|
procedure Test_Expression_Is_Foldable
|
||||||
(N : Node_Id;
|
(N : Node_Id;
|
||||||
Op1 : Node_Id;
|
Op1 : Node_Id;
|
||||||
|
@ -1458,6 +1465,15 @@ package body Sem_Eval is
|
||||||
return;
|
return;
|
||||||
end if;
|
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
|
-- Fold for cases where both operands are of integer type
|
||||||
|
|
||||||
if Is_Integer_Type (Ltype) and then Is_Integer_Type (Rtype) then
|
if Is_Integer_Type (Ltype) and then Is_Integer_Type (Rtype) then
|
||||||
|
@ -3395,6 +3411,12 @@ package body Sem_Eval is
|
||||||
return;
|
return;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
if Etype (Right) = Universal_Integer
|
||||||
|
or else Etype (Right) = Universal_Real
|
||||||
|
then
|
||||||
|
Test_Ambiguous_Operator (N);
|
||||||
|
end if;
|
||||||
|
|
||||||
-- Fold for integer case
|
-- Fold for integer case
|
||||||
|
|
||||||
if Is_Integer_Type (Etype (N)) then
|
if Is_Integer_Type (Etype (N)) then
|
||||||
|
@ -4699,6 +4721,78 @@ package body Sem_Eval is
|
||||||
end if;
|
end if;
|
||||||
end Test;
|
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 --
|
-- Test_Expression_Is_Foldable --
|
||||||
---------------------------------
|
---------------------------------
|
||||||
|
|
Loading…
Reference in New Issue