+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.
-- 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 --
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);
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.
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.
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;
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");
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,
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;
end if;
Id.Project := Project;
+ Id.Location := Location;
Id.Source_Dir_Rank := Source_Dir_Rank;
Id.Language := Lang_Id;
Id.Kind := Kind;
(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;
Extending := Project.Extends /= No_Project;
- Check_Package_Naming (Project, Data, Bodies => Bodies, Specs => Specs);
+ Check_Package_Naming (Project, Data);
-- Find the sources
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
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
-- 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
(Name => Source_Name,
Location => Location,
Source => No_Source,
+ Listed => True,
Found => False);
+
+ else
+ Name_Loc.Listed := True;
end if;
Source_Names_Htable.Set
(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;
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,
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
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
No_Source_Data : constant Source_Data :=
(Project => No_Project,
+ Location => No_Location,
Source_Dir_Rank => 0,
Language => No_Language_Index,
In_Interfaces => True,
-- 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;
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
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
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 --
---------------------------------
projects / thirdparty / gcc.git / commitdiff
