git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

[multiple changes] 

2012-02-22  Vincent Pucci  <pucci@adacore.com>

	* rtsfind.adb (Get_Unit_Name): Ada_Numerics_Child and
	System_Dim_Child cases added.
	* rtsfind.ads: Ada_Numerics,
	Ada_Numerics_Generic_Elementary_Functions, System_Dim,
	System_Dim_Float_IO and System_Dim_Integer_IO added to the list
	of RTU_Id.  Ada_Numerics_Child and System_Dim_Child added as
	new RTU_Id subtypes.
	* sem_dim.adb (Is_Dim_IO_Package_Entity): Use of
	Rtsfind to verify the package entity is located either
	in System.Dim.Integer_IO or in System.Dim.Float_IO.
	(Is_Dim_IO_Package_Instantiation): Minor
	changes.  (Is_Elementary_Function_Call): Removed.
	(Is_Elementary_Function_Entity): New routine.
	(Is_Procedure_Put_Call): Is_Dim_IO_Package_Entity call added.
	* snames.ads-tmpl: Name_Dim and Name_Generic_Elementary_Functions
	removed.

2012-02-22  Vincent Pucci  <pucci@adacore.com>

	* sem_prag.adb: Minor reformatting.

2012-02-22  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch3.adb (Find_Type_Name): When analyzing a private type
	declaration that is the completion of a tagged incomplete type, do
	not associate the class-wide type already created with the private
	type to prevent order-of-elaboration issues in the back-end.
	* exp_disp.adb (Find_Specific_Type): Find specific type of
	a class-wide type, and handle the case of an incomplete type
	coming	either from a limited_with clause or from an incomplete
	type declaration. Used when expanding a dispatchin call and
	generating tag checks (minor refactoring).

From-SVN: r184473
This commit is contained in:
Arnaud Charlet 2012-02-22 14:53:38 +01:00
parent aaf1cd904e
commit 98ee6f8d5f
8 changed files with 203 additions and 118 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
gcc/ada/ChangeLog
View File

@ -1,3 +1,38 @@
2012-02-22 Vincent Pucci <pucci@adacore.com>
* rtsfind.adb (Get_Unit_Name): Ada_Numerics_Child and
System_Dim_Child cases added.
* rtsfind.ads: Ada_Numerics,
Ada_Numerics_Generic_Elementary_Functions, System_Dim,
System_Dim_Float_IO and System_Dim_Integer_IO added to the list
of RTU_Id. Ada_Numerics_Child and System_Dim_Child added as
new RTU_Id subtypes.
* sem_dim.adb (Is_Dim_IO_Package_Entity): Use of
Rtsfind to verify the package entity is located either
in System.Dim.Integer_IO or in System.Dim.Float_IO.
(Is_Dim_IO_Package_Instantiation): Minor
changes. (Is_Elementary_Function_Call): Removed.
(Is_Elementary_Function_Entity): New routine.
(Is_Procedure_Put_Call): Is_Dim_IO_Package_Entity call added.
* snames.ads-tmpl: Name_Dim and Name_Generic_Elementary_Functions
removed.
2012-02-22 Vincent Pucci <pucci@adacore.com>
* sem_prag.adb: Minor reformatting.
2012-02-22 Ed Schonberg <schonberg@adacore.com>
* sem_ch3.adb (Find_Type_Name): When analyzing a private type
declaration that is the completion of a tagged incomplete type, do
not associate the class-wide type already created with the private
type to prevent order-of-elaboration issues in the back-end.
* exp_disp.adb (Find_Specific_Type): Find specific type of
a class-wide type, and handle the case of an incomplete type
coming either from a limited_with clause or from an incomplete
type declaration. Used when expanding a dispatchin call and
generating tag checks (minor refactoring).
2012-02-22 Robert Dewar <dewar@adacore.com>
* exp_ch5.adb: Add comment.

38
gcc/ada/exp_disp.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2012, 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- --
@ -75,6 +75,11 @@ package body Exp_Disp is
-- Ada 2005 (AI-251): Returns the fixed position in the dispatch table
-- of the default primitive operations.
function Find_Specific_Type (CW : Entity_Id) return Entity_Id;
-- Find specific type of a class-wide type, and handle the case of an
-- incomplete type coming either from a limited_with clause or from an
-- incomplete type declaration.
function Has_DT (Typ : Entity_Id) return Boolean;
pragma Inline (Has_DT);
-- Returns true if we generate a dispatch table for tagged type Typ
@ -178,11 +183,7 @@ package body Exp_Disp is
CW_Typ := Class_Wide_Type (Ctrl_Typ);
end if;
Typ := Root_Type (CW_Typ);
if Ekind (Typ) = E_Incomplete_Type then
Typ := Non_Limited_View (Typ);
end if;
Typ := Find_Specific_Type (CW_Typ);
if not Is_Limited_Type (Typ) then
Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
@ -746,11 +747,7 @@ package body Exp_Disp is
CW_Typ := Class_Wide_Type (Ctrl_Typ);
end if;
Typ := Root_Type (CW_Typ);
if Ekind (Typ) = E_Incomplete_Type then
Typ := Non_Limited_View (Typ);
end if;
Typ := Find_Specific_Type (CW_Typ);
if not Is_Limited_Type (Typ) then
Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
@ -1884,6 +1881,25 @@ package body Exp_Disp is
end if;
end Expand_Interface_Thunk;
------------------------
-- Find_Specific_Type --
------------------------
function Find_Specific_Type (CW : Entity_Id) return Entity_Id is
Typ : Entity_Id := Root_Type (CW);
begin
if Ekind (Typ) = E_Incomplete_Type then
if From_With_Type (Typ) then
Typ := Non_Limited_View (Typ);
else
Typ := Full_View (Typ);
end if;
end if;
return Typ;
end Find_Specific_Type;
--------------------------
-- Has_CPP_Constructors --
--------------------------

9
gcc/ada/rtsfind.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2012, 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- --
@ -313,6 +313,9 @@ package body Rtsfind is
elsif U_Id in Ada_Interrupts_Child then
Name_Buffer (15) := '.';
elsif U_Id in Ada_Numerics_Child then
Name_Buffer (13) := '.';
elsif U_Id in Ada_Real_Time_Child then
Name_Buffer (14) := '.';
@ -338,6 +341,10 @@ package body Rtsfind is
elsif U_Id in System_Child then
Name_Buffer (7) := '.';
if U_Id in System_Dim_Child then
Name_Buffer (11) := '.';
end if;
if U_Id in System_Multiprocessors_Child then
Name_Buffer (23) := '.';
end if;

22
gcc/ada/rtsfind.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2012, 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- --
@ -125,6 +125,7 @@ package Rtsfind is
Ada_Exceptions,
Ada_Finalization,
Ada_Interrupts,
Ada_Numerics,
Ada_Real_Time,
Ada_Streams,
Ada_Strings,
@ -144,6 +145,10 @@ package Rtsfind is
Ada_Interrupts_Names,
-- Children of Ada.Numerics
Ada_Numerics_Generic_Elementary_Functions,
-- Children of Ada.Real_Time
Ada_Real_Time_Delays,
@ -223,6 +228,7 @@ package Rtsfind is
System_Concat_7,
System_Concat_8,
System_Concat_9,
System_Dim,
System_DSA_Services,
System_DSA_Types,
System_Exception_Table,
@ -372,6 +378,11 @@ package Rtsfind is
System_WWd_Enum,
System_WWd_Wchar,
-- Children of System.Dim
System_Dim_Float_IO,
System_Dim_Integer_IO,
-- Children of System.Multiprocessors
System_Multiprocessors_Dispatching_Domains,
@ -413,6 +424,11 @@ package Rtsfind is
Ada_Interrupts_Names .. Ada_Interrupts_Names;
-- Range of values for children of Ada.Interrupts
subtype Ada_Numerics_Child is Ada_Child
range Ada_Numerics_Generic_Elementary_Functions ..
Ada_Numerics_Generic_Elementary_Functions;
-- Range of values for children of Ada.Numerics
subtype Ada_Real_Time_Child is Ada_Child
range Ada_Real_Time_Delays .. Ada_Real_Time_Timing_Events;
-- Range of values for children of Ada.Real_Time
@ -445,6 +461,10 @@ package Rtsfind is
range System_Address_Image .. System_Tasking_Stages;
-- Range of values for children or grandchildren of System
subtype System_Dim_Child is RTU_Id
range System_Dim_Float_IO .. System_Dim_Integer_IO;
-- Range of values for children of System.Dim
subtype System_Multiprocessors_Child is RTU_Id
range System_Multiprocessors_Dispatching_Domains ..
System_Multiprocessors_Dispatching_Domains;

10
gcc/ada/sem_ch3.adb
View File

@ -14968,7 +14968,15 @@ package body Sem_Ch3 is
then
Set_Ekind (Id, Ekind (Prev)); -- will be reset later
Set_Class_Wide_Type (Id, Class_Wide_Type (Prev));
Set_Etype (Class_Wide_Type (Id), Id);
-- If the incomplete type is completed by a private declaration
-- the class-wide type remains associated with the incomplete
-- type, to prevent order-of-elaboration issues in gigi, else
-- we associate the class-wide type with the known full view.
if Nkind (N) /= N_Private_Type_Declaration then
Set_Etype (Class_Wide_Type (Id), Id);
end if;
end if;
-- Case of full declaration of private type

198
gcc/ada/sem_dim.adb
View File

@ -36,7 +36,6 @@ with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
@ -1359,94 +1358,105 @@ package body Sem_Dim is
-- Analyze_Dimension_Function_Call --
-------------------------------------
-- Propagate the dimensions from the returned type to the call node. Note
-- that there is a special treatment for elementary function calls. Indeed
-- for Sqrt call, the resulting dimensions equal to half the dimensions of
-- the actual, and for other elementary calls, this routine check that
-- every actuals are dimensionless.
procedure Analyze_Dimension_Function_Call (N : Node_Id) is
Name_Call : constant Node_Id := Name (N);
Actuals : constant List_Id := Parameter_Associations (N);
Name_Call : constant Node_Id := Name (N);
Actual : Node_Id;
Dims_Of_Actual : Dimension_Type;
Dims_Of_Call : Dimension_Type;
Ent : Entity_Id;
function Is_Elementary_Function_Call return Boolean;
-- Return True if the call is a call of an elementary function (see
function Is_Elementary_Function_Entity (E : Entity_Id) return Boolean;
-- Given E the original subprogram entity, return True if the call is a
-- an elementary function call (see
-- Ada.Numerics.Generic_Elementary_Functions).
---------------------------------
-- Is_Elementary_Function_Call --
---------------------------------
-----------------------------------
-- Is_Elementary_Function_Entity --
-----------------------------------
function Is_Elementary_Function_Call return Boolean is
Ent : Entity_Id;
function Is_Elementary_Function_Entity (E : Entity_Id) return Boolean is
Loc : constant Source_Ptr := Sloc (E);
begin
if Is_Entity_Name (Name_Call) then
Ent := Entity (Name_Call);
-- Check the function entity is located in
-- Ada.Numerics.Generic_Elementary_Functions.
-- Check the procedure is defined in an instantiation of a generic
-- package.
if Is_Generic_Instance (Scope (Ent)) then
Ent := Cunit_Entity (Get_Source_Unit (Ent));
-- Check the name of the generic package is
-- Generic_Elementary_Functions
return
Is_Library_Level_Entity (Ent)
and then Chars (Ent) = Name_Generic_Elementary_Functions;
end if;
end if;
return False;
end Is_Elementary_Function_Call;
return
Loc > No_Location
and then
Is_RTU
(Cunit_Entity (Get_Source_Unit (Loc)),
Ada_Numerics_Generic_Elementary_Functions);
end Is_Elementary_Function_Entity;
-- Start of processing for Analyze_Dimension_Function_Call
begin
-- Elementary function case
-- Look for elementary function call
if Is_Elementary_Function_Call then
if Is_Entity_Name (Name_Call) then
Ent := Entity (Name_Call);
-- Get the original subprogram entity following the renaming chain
if Present (Alias (Ent)) then
Ent := Alias (Ent);
end if;
-- Elementary function case
if Is_Elementary_Function_Entity (Ent) then
-- Sqrt function call case
if Chars (Name_Call) = Name_Sqrt then
Dims_Of_Call := Dimensions_Of (First (Actuals));
if Chars (Ent) = Name_Sqrt then
Dims_Of_Call := Dimensions_Of (First (Actuals));
if Exists (Dims_Of_Call) then
for Position in Dims_Of_Call'Range loop
Dims_Of_Call (Position) :=
Dims_Of_Call (Position) * Rational'(Numerator => 1,
if Exists (Dims_Of_Call) then
for Position in Dims_Of_Call'Range loop
Dims_Of_Call (Position) :=
Dims_Of_Call (Position) * Rational'(Numerator => 1,
Denominator => 2);
end loop;
end loop;
Set_Dimensions (N, Dims_Of_Call);
end if;
-- All other functions in Ada.Numerics.Generic_Elementary_Functions
-- case. Note that all parameters here should be dimensionless.
else
Actual := First (Actuals);
while Present (Actual) loop
Dims_Of_Actual := Dimensions_Of (Actual);
if Exists (Dims_Of_Actual) then
Error_Msg_NE ("parameter should be dimensionless for " &
"elementary function&",
Actual,
Name_Call);
Error_Msg_N ("\parameter " & Dimensions_Msg_Of (Actual),
Actual);
Set_Dimensions (N, Dims_Of_Call);
end if;
Next (Actual);
end loop;
-- All other elementary functions case. Note that every actual
-- here should be dimensionless.
else
Actual := First (Actuals);
while Present (Actual) loop
Dims_Of_Actual := Dimensions_Of (Actual);
if Exists (Dims_Of_Actual) then
Error_Msg_NE ("parameter should be dimensionless for " &
"elementary function&",
Actual,
Name_Call);
Error_Msg_N ("\parameter " & Dimensions_Msg_Of (Actual),
Actual);
end if;
Next (Actual);
end loop;
end if;
return;
end if;
-- Other case
else
Analyze_Dimension_Has_Etype (N);
end if;
-- Other cases
Analyze_Dimension_Has_Etype (N);
end Analyze_Dimension_Function_Call;
---------------------------------
@ -2226,28 +2236,31 @@ package body Sem_Dim is
function Is_Procedure_Put_Call return Boolean is
Ent : Entity_Id;
Loc : Source_Ptr;
begin
-- There are three different Put routine in each generic package
-- Check that the current procedure call is one of them
-- There are three different Put routines in each generic dim IO
-- package. Verify the current procedure call is one of them.
if Is_Entity_Name (Name_Call) then
Ent := Entity (Name_Call);
-- Check that the name of the procedure is Put
-- Check the procedure is defined in an instantiation of a
-- generic package.
-- Get the original subprogram entity following the renaming chain
if Chars (Name_Call) = Name_Put
and then Is_Generic_Instance (Scope (Ent))
then
Ent := Cunit_Entity (Get_Source_Unit (Ent));
-- Verify that the generic package is either
-- System.Dim.Float_IO or System.Dim.Integer_IO.
return Is_Dim_IO_Package_Entity (Ent);
if Present (Alias (Ent)) then
Ent := Alias (Ent);
end if;
Loc := Sloc (Ent);
-- Check the name of the entity subprogram is Put and verify this
-- entity is located in either System.Dim.Float_IO or
-- System.Dim.Integer_IO.
return Chars (Ent) = Name_Put
and then Loc > No_Location
and then Is_Dim_IO_Package_Entity
(Cunit_Entity (Get_Source_Unit (Loc)));
end if;
return False;
@ -2499,22 +2512,14 @@ package body Sem_Dim is
-- Is_Dim_IO_Package_Entity --
------------------------------
-- Why all this comparison of names, why not use Is_RTE and Is_RTU ???
function Is_Dim_IO_Package_Entity (E : Entity_Id) return Boolean is
begin
-- Check the package entity is standard and its scope is either
-- System.Dim.Float_IO or System.Dim.Integer_IO.
-- Check the package entity corresponds to System.Dim.Float_IO or
-- System.Dim.Integer_IO.
if Is_Library_Level_Entity (E)
and then (Chars (E) = Name_Float_IO
or else Chars (E) = Name_Integer_IO)
then
return Chars (Scope (E)) = Name_Dim
and Chars (Scope (Scope (E))) = Name_System;
end if;
return False;
return
Is_RTU (E, System_Dim_Float_IO)
or Is_RTU (E, System_Dim_Integer_IO);
end Is_Dim_IO_Package_Entity;
-------------------------------------
@ -2523,19 +2528,14 @@ package body Sem_Dim is
function Is_Dim_IO_Package_Instantiation (N : Node_Id) return Boolean is
Gen_Id : constant Node_Id := Name (N);
Ent : Entity_Id;
begin
if Is_Entity_Name (Gen_Id) then
Ent := Entity (Gen_Id);
-- Check that the instantiated package is either System.Dim.Float_IO
-- or System.Dim.Integer_IO.
-- Verify that the instantiated package is either System.Dim.Float_IO
-- or System.Dim.Integer_IO.
return Is_Dim_IO_Package_Entity (Ent);
end if;
return False;
return
Is_Entity_Name (Gen_Id)
and then Is_Dim_IO_Package_Entity (Entity (Gen_Id));
end Is_Dim_IO_Package_Instantiation;
----------------

7
gcc/ada/sem_prag.adb
View File

@ -14970,14 +14970,15 @@ package body Sem_Prag is
-- Follow subprogram renaming chain
Result := Def_Id;
while Is_Subprogram (Result)
if Is_Subprogram (Result)
and then
Nkind (Parent (Declaration_Node (Result))) =
N_Subprogram_Renaming_Declaration
and then Present (Alias (Result))
loop
then
Result := Alias (Result);
end loop;
end if;
return Result;
end Get_Base_Subprogram;

2
gcc/ada/snames.ads-tmpl
View File

@ -225,8 +225,6 @@ package Snames is
-- Names used by the analyzer and expander for aspect Dimension and
-- Dimension_System to deal with Sqrt and IO routines.
Name_Dim : constant Name_Id := N + $; -- Ada 12
Name_Generic_Elementary_Functions : constant Name_Id := N + $; -- Ada 12
Name_Item : constant Name_Id := N + $; -- Ada 12
Name_Sqrt : constant Name_Id := N + $; -- Ada 12
Name_Symbols : constant Name_Id := N + $; -- Ada 12