mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-10 03:50:26 +08:00
Code Issues Packages Projects Releases Wiki Activity

snames.h, [...]: Add Attr_To_Any, Attr_From_Any and Attr_TypeCode defines.

Browse Source 
2008-08-04  Kevin Pouget  <pouget@adacore.com>

	* snames.h, snames.adb, snames.ads:
	Add Attr_To_Any, Attr_From_Any and Attr_TypeCode defines.

	* exp_dist.ads, exp_dist.adb: Add Build_From_Any_Call,
	Build_To_Any_Call and Build_TypeCode_Call procedures.

	* exp_attr.adb, sem_attr.adb: Add corresponding cases.

	* rtsfind.ads: Add corresponding names.

	* tbuild.adb: Update prefix restrictions to allow '_' character.

From-SVN: r138598
This commit is contained in:
Arnaud Charlet 2008-08-04 11:50:09 +02:00
parent 9450205a0c
commit 54838d1f88
10 changed files with 747 additions and 536 deletions

27
gcc/ada/ChangeLog

@ -1,3 +1,30 @@
2008-08-04 Jerome Lambourg <lambourg@adacore.com>
* g-comlin.adb (Group_Switches): Preserve the switch order when
grouping and allow switch grouping of switches with more than one
character extension (e.g. gnatw.x).
(Args_From_Expanded): Remove this now obsolete method.
2008-08-04 Ed Schonberg <schonberg@adacore.com>
* exp_ch4.adb (Get_Allocator_Final_List): Freeze anonymous type for
chain at once, to ensure that type is properly decorated for back-end,
when allocator appears within a loop.
2008-08-04 Kevin Pouget <pouget@adacore.com>
* snames.h, snames.adb, snames.ads:
Add Attr_To_Any, Attr_From_Any and Attr_TypeCode defines.
* exp_dist.ads, exp_dist.adb: Add Build_From_Any_Call,
Build_To_Any_Call and Build_TypeCode_Call procedures.
* exp_attr.adb, sem_attr.adb: Add corresponding cases.
* rtsfind.ads: Add corresponding names.
* tbuild.adb: Update prefix restrictions to allow '_' character.
2008-08-04 Doug Rupp <rupp@adacore.com>
* gigi.h (fill_vms_descriptor): Add third parameter gnat_actual

46
gcc/ada/exp_attr.adb

@ -33,6 +33,7 @@ with Exp_Ch2; use Exp_Ch2;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch9; use Exp_Ch9;
with Exp_Dist; use Exp_Dist;
with Exp_Imgv; use Exp_Imgv;
with Exp_Pakd; use Exp_Pakd;
with Exp_Strm; use Exp_Strm;
@ -2074,6 +2075,22 @@ package body Exp_Attr is
when Attribute_Fraction =>
Expand_Fpt_Attribute_R (N);
--------------
-- From_Any --
--------------
when Attribute_From_Any => From_Any : declare
P_Type : constant Entity_Id := Etype (Pref);
Decls : constant List_Id := New_List;
begin
Rewrite (N,
Build_From_Any_Call (P_Type,
Relocate_Node (First (Exprs)),
Decls));
Insert_Actions (N, Decls);
Analyze_And_Resolve (N, P_Type);
end From_Any;
--------------
-- Identity --
--------------
@ -4396,6 +4413,22 @@ package body Exp_Attr is
Relocate_Node (First (Exprs))));
Analyze_And_Resolve (N, RTE (RE_Address));
------------
-- To_Any --
------------
when Attribute_To_Any => To_Any : declare
P_Type : constant Entity_Id := Etype (Pref);
Decls : constant List_Id := New_List;
begin
Rewrite (N,
Build_To_Any_Call
(Convert_To (P_Type,
Relocate_Node (First (Exprs))), Decls));
Insert_Actions (N, Decls);
Analyze_And_Resolve (N, RTE (RE_Any));
end To_Any;
----------------
-- Truncation --
----------------
@ -4409,6 +4442,19 @@ package body Exp_Attr is
Expand_Fpt_Attribute_R (N);
end if;
--------------
-- TypeCode --
--------------
when Attribute_TypeCode => TypeCode : declare
P_Type : constant Entity_Id := Etype (Pref);
Decls : constant List_Id := New_List;
begin
Rewrite (N, Build_TypeCode_Call (Loc, P_Type, Decls));
Insert_Actions (N, Decls);
Analyze_And_Resolve (N, RTE (RE_TypeCode));
end TypeCode;
-----------------------
-- Unbiased_Rounding --
-----------------------

89
gcc/ada/exp_dist.adb

@ -858,6 +858,25 @@ package body Exp_Dist is
end PolyORB_Support;
-- The following PolyORB-specific subprograms are made visible to Exp_Attr:
function Build_From_Any_Call
(Typ : Entity_Id;
N : Node_Id;
Decls : List_Id) return Node_Id
renames PolyORB_Support.Helpers.Build_From_Any_Call;
function Build_To_Any_Call
(N : Node_Id;
Decls : List_Id) return Node_Id
renames PolyORB_Support.Helpers.Build_To_Any_Call;
function Build_TypeCode_Call
(Loc : Source_Ptr;
Typ : Entity_Id;
Decls : List_Id) return Node_Id
renames PolyORB_Support.Helpers.Build_TypeCode_Call;
------------------------------------
-- Local variables and structures --
------------------------------------
@ -8218,12 +8237,11 @@ package body Exp_Dist is
-- point type from Standard, or the smallest unsigned (modular) type
-- from System.Unsigned_Types, whose range encompasses that of Typ.
function Make_Stream_Procedure_Function_Name
function Make_Helper_Function_Name
(Loc : Source_Ptr;
Typ : Entity_Id;
Nam : Name_Id) return Entity_Id;
-- Return the name to be assigned for stream subprogram Nam of Typ.
-- (copied from exp_strm.adb, should be shared???)
-- Return the name to be assigned for helper subprogram Nam of Typ
------------------------------------------------------------
-- Common subprograms for building various tree fragments --
@ -8432,6 +8450,11 @@ package body Exp_Dist is
elsif U_Type = Standard_String then
Lib_RE := RE_FA_String;
-- Special DSA types
elsif Is_RTE (U_Type, RE_Any_Content_Ptr) then
Lib_RE := RE_FA_A;
-- Other (non-primitive) types
else
@ -8493,8 +8516,7 @@ package body Exp_Dist is
return;
end if;
Fnam :=
Make_Stream_Procedure_Function_Name (Loc, Typ, Name_uFrom_Any);
Fnam := Make_Helper_Function_Name (Loc, Typ, Name_From_Any);
Spec :=
Make_Function_Specification (Loc,
@ -9293,7 +9315,13 @@ package body Exp_Dist is
elsif U_Type = Standard_String then
Lib_RE := RE_TA_String;
-- Special DSA types
elsif Is_RTE (U_Type, RE_Any_Content_Ptr) then
Lib_RE := RE_TA_A;
elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then
-- No corresponding FA_TC ???
Lib_RE := RE_TA_TC;
-- Other (non-primitive) types
@ -9358,8 +9386,7 @@ package body Exp_Dist is
return;
end if;
Fnam :=
Make_Stream_Procedure_Function_Name (Loc, Typ, Name_uTo_Any);
Fnam := Make_Helper_Function_Name (Loc, Typ, Name_To_Any);
Spec :=
Make_Function_Specification (Loc,
@ -9976,7 +10003,7 @@ package body Exp_Dist is
-- not been set yet, so can't call Find_Inherited_TSS.
if Typ = RTE (RE_Any) then
Fnam := RTE (RE_TC_Any);
Fnam := RTE (RE_TC_A);
else
-- First simple case where the TypeCode is present
@ -10057,6 +10084,11 @@ package body Exp_Dist is
elsif U_Type = Standard_String then
Lib_RE := RE_TC_String;
-- Special DSA types
elsif Is_RTE (U_Type, RE_Any_Content_Ptr) then
Lib_RE := RE_TC_A;
-- Other (non-primitive) types
else
@ -10100,8 +10132,7 @@ package body Exp_Dist is
Stms : constant List_Id := New_List;
TCNam : constant Entity_Id :=
Make_Stream_Procedure_Function_Name (Loc,
Typ, Name_uTypeCode);
Make_Helper_Function_Name (Loc, Typ, Name_TypeCode);
Parameters : List_Id;
@ -10964,30 +10995,40 @@ package body Exp_Dist is
end;
end Append_Array_Traversal;
-----------------------------------------
-- Make_Stream_Procedure_Function_Name --
-----------------------------------------
-------------------------------
-- Make_Helper_Function_Name --
-------------------------------
function Make_Stream_Procedure_Function_Name
function Make_Helper_Function_Name
(Loc : Source_Ptr;
Typ : Entity_Id;
Nam : Name_Id) return Entity_Id
is
begin
-- For tagged types, we use a canonical name so that it matches
-- the primitive spec. For all other cases, we use a serialized
-- name so that multiple generations of the same procedure do not
-- clash.
if Is_Tagged_Type (Typ) then
return Make_Defining_Identifier (Loc, Nam);
else
declare
Serial : Nat := 0;
-- For tagged types, we use a canonical name so that it matches
-- the primitive spec. For all other cases, we use a serialized
-- name so that multiple generations of the same procedure do
-- not clash.
begin
if not Is_Tagged_Type (Typ) then
Serial := Increment_Serial_Number;
end if;
-- Use prefixed underscore to avoid potential clash with used
-- identifier (we use attribute names for Nam).
return
Make_Defining_Identifier (Loc,
Chars =>
New_External_Name (Nam, ' ', Increment_Serial_Number));
end if;
end Make_Stream_Procedure_Function_Name;
New_External_Name
(Related_Id => Nam,
Suffix => ' ', Suffix_Index => Serial,
Prefix => '_'));
end;
end Make_Helper_Function_Name;
end Helpers;
-----------------------------------

33
gcc/ada/exp_dist.ads

@ -129,4 +129,37 @@ package Exp_Dist is
-- a remote call) satisfies the requirements for being transportable
-- across partitions, raising Program_Error if it does not.
----------------------------------------------------------------
-- Functions for expansion of PolyORB/DSA specific attributes --
----------------------------------------------------------------
function Build_From_Any_Call
(Typ : Entity_Id;
N : Node_Id;
Decls : List_Id) return Node_Id;
-- Build call to From_Any attribute function of type Typ with expression
-- N as actual parameter. Decls is the declarations list for an appropriate
-- enclosing scope of the point where the call will be inserted; if the
-- From_Any attribute for Typ needs to be generated at this point, its
-- declaration is appended to Decls.
function Build_To_Any_Call
(N : Node_Id;
Decls : List_Id) return Node_Id;
-- Build call to To_Any attribute function with expression as actual
-- parameter. Decls is the declarations list for an appropriate
-- enclosing scope of the point where the call will be inserted; if
-- the To_Any attribute for Typ needs to be generated at this point,
-- its declaration is appended to Decls.
function Build_TypeCode_Call
(Loc : Source_Ptr;
Typ : Entity_Id;
Decls : List_Id) return Node_Id;
-- Build call to TypeCode attribute function for Typ. Decls is the
-- declarations list for an appropriate enclosing scope of the point
-- where the call will be inserted; if the To_Any attribute for Typ
-- needs to be generated at this point, its declaration is appended
-- to Decls.
end Exp_Dist;

11
gcc/ada/rtsfind.ads

@ -209,6 +209,7 @@ package Rtsfind is
System_Compare_Array_Unsigned_64,
System_Compare_Array_Unsigned_8,
System_DSA_Services,
System_DSA_Types,
System_Exception_Table,
System_Exceptions,
System_Exn_Int,
@ -696,6 +697,8 @@ package Rtsfind is
RE_Get_Local_Partition_Id, -- System.DSA_Services
RE_Get_Passive_Partition_Id, -- System.DSA_Services
RE_Any_Content_Ptr, -- System.DSA_Types
RE_Register_Exception, -- System.Exception_Table
RE_Local_Raise, -- System.Exceptions
@ -1157,6 +1160,7 @@ package Rtsfind is
RE_BS_To_Any, -- System.Partition_Interface
RE_Any_To_BS, -- System.Partition_Interface
RE_FA_A, -- System.Partition_Interface
RE_FA_B, -- System.Partition_Interface
RE_FA_C, -- System.Partition_Interface
RE_FA_F, -- System.Partition_Interface
@ -1205,7 +1209,7 @@ package Rtsfind is
RE_TC_Build, -- System.Partition_Interface
RE_Get_TC, -- System.Partition_Interface
RE_Set_TC, -- System.Partition_Interface
RE_TC_Any, -- System.Partition_Interface
RE_TC_A, -- System.Partition_Interface
RE_TC_B, -- System.Partition_Interface
RE_TC_C, -- System.Partition_Interface
RE_TC_F, -- System.Partition_Interface
@ -1850,6 +1854,8 @@ package Rtsfind is
RE_Get_Local_Partition_Id => System_DSA_Services,
RE_Get_Passive_Partition_Id => System_DSA_Services,
RE_Any_Content_Ptr => System_DSA_Types,
RE_Register_Exception => System_Exception_Table,
RE_Local_Raise => System_Exceptions,
@ -2302,6 +2308,7 @@ package Rtsfind is
RE_BS_To_Any => System_Partition_Interface,
RE_Any_To_BS => System_Partition_Interface,
RE_FA_A => System_Partition_Interface,
RE_FA_B => System_Partition_Interface,
RE_FA_C => System_Partition_Interface,
RE_FA_F => System_Partition_Interface,
@ -2350,7 +2357,7 @@ package Rtsfind is
RE_TC_Build => System_Partition_Interface,
RE_Get_TC => System_Partition_Interface,
RE_Set_TC => System_Partition_Interface,
RE_TC_Any => System_Partition_Interface,
RE_TC_A => System_Partition_Interface,
RE_TC_B => System_Partition_Interface,
RE_TC_C => System_Partition_Interface,
RE_TC_F => System_Partition_Interface,

54
gcc/ada/sem_attr.adb

@ -315,6 +315,9 @@ package body Sem_Attr is
-- corresponding possible defined attribute function (e.g. for the
-- Read attribute, Nam will be TSS_Stream_Read).
procedure Check_PolyORB_Attribute;
-- Validity checking for PolyORB/DSA attribute
procedure Check_Task_Prefix;
-- Verify that prefix of attribute N is a task or task type
@ -1380,6 +1383,23 @@ package body Sem_Attr is
end if;
end Check_Object_Reference;
----------------------------
-- Check_PolyORB_Attribute --
----------------------------
procedure Check_PolyORB_Attribute is
begin
Validate_Non_Static_Attribute_Function_Call;
Check_Type;
Check_Not_CPP_Type;
if Get_PCS_Name /= Name_PolyORB_DSA then
Error_Attr
("attribute% requires the 'Poly'O'R'B 'P'C'S", N);
end if;
end Check_PolyORB_Attribute;
------------------------
-- Check_Program_Unit --
------------------------
@ -2976,6 +2996,15 @@ package body Sem_Attr is
Set_Etype (N, P_Base_Type);
Resolve (E1, P_Base_Type);
--------------
-- From_Any --
--------------
when Attribute_From_Any =>
Check_E1;
Check_PolyORB_Attribute;
Set_Etype (N, P_Base_Type);
-----------------------
-- Has_Access_Values --
-----------------------
@ -4238,6 +4267,15 @@ package body Sem_Attr is
Analyze_And_Resolve (E1, Any_Integer);
Set_Etype (N, RTE (RE_Address));
------------
-- To_Any --
------------
when Attribute_To_Any =>
Check_E1;
Check_PolyORB_Attribute;
Set_Etype (N, RTE (RE_Any));
----------------
-- Truncation --
----------------
@ -4257,6 +4295,15 @@ package body Sem_Attr is
Check_Not_Incomplete_Type;
Set_Etype (N, RTE (RE_Type_Class));
------------
-- To_Any --
------------
when Attribute_TypeCode =>
Check_E0;
Check_PolyORB_Attribute;
Set_Etype (N, RTE (RE_TypeCode));
-----------------
-- UET_Address --
-----------------
@ -7253,6 +7300,13 @@ package body Sem_Attr is
end if;
end Width;
-- The following attributes denote function that cannot be folded
when Attribute_From_Any |
Attribute_To_Any |
Attribute_TypeCode =>
null;
-- The following attributes can never be folded, and furthermore we
-- should not even have entered the case statement for any of these.
-- Note that in some cases, the values have already been folded as

6
gcc/ada/snames.adb

@ -104,9 +104,6 @@ package body Snames is
"finalize#" &
"next#" &
"prev#" &
"_typecode#" &
"_from_any#" &
"_to_any#" &
"allocate#" &
"deallocate#" &
"dereference#" &
@ -557,6 +554,7 @@ package body Snames is
"copy_sign#" &
"floor#" &
"fraction#" &
"from_any#" &
"image#" &
"input#" &
"machine#" &
@ -567,7 +565,9 @@ package body Snames is
"remainder#" &
"rounding#" &
"succ#" &
"to_any#" &
"truncation#" &
"typecode#" &
"value#" &
"wide_image#" &
"wide_wide_image#" &

962
gcc/ada/snames.ads

File diff suppressed because it is too large Load Diff

53
gcc/ada/snames.h

@ -164,31 +164,34 @@ extern unsigned char Get_Attribute_Id (int);
#define Attr_Copy_Sign 117
#define Attr_Floor 118
#define Attr_Fraction 119
#define Attr_Image 120
#define Attr_Input 121
#define Attr_Machine 122
#define Attr_Max 123
#define Attr_Min 124
#define Attr_Model 125
#define Attr_Pred 126
#define Attr_Remainder 127
#define Attr_Rounding 128
#define Attr_Succ 129
#define Attr_Truncation 130
#define Attr_Value 131
#define Attr_Wide_Image 132
#define Attr_Wide_Wide_Image 133
#define Attr_Wide_Value 134
#define Attr_Wide_Wide_Value 135
#define Attr_Output 136
#define Attr_Read 137
#define Attr_Write 138
#define Attr_Elab_Body 139
#define Attr_Elab_Spec 140
#define Attr_Storage_Pool 141
#define Attr_Base 142
#define Attr_Class 143
#define Attr_Stub_Type 144
#define Attr_From_Any 120
#define Attr_Image 121
#define Attr_Input 122
#define Attr_Machine 123
#define Attr_Max 124
#define Attr_Min 125
#define Attr_Model 126
#define Attr_Pred 127
#define Attr_Remainder 128
#define Attr_Rounding 129
#define Attr_Succ 130
#define Attr_To_Any 131
#define Attr_Truncation 132
#define Attr_TypeCode 133
#define Attr_Value 134
#define Attr_Wide_Image 135
#define Attr_Wide_Wide_Image 136
#define Attr_Wide_Value 137
#define Attr_Wide_Wide_Value 138
#define Attr_Output 139
#define Attr_Read 140
#define Attr_Write 141
#define Attr_Elab_Body 142
#define Attr_Elab_Spec 143
#define Attr_Storage_Pool 144
#define Attr_Base 145
#define Attr_Class 146
#define Attr_Stub_Type 147
/* Define the numeric values for the conventions. */

2
gcc/ada/tbuild.adb

@ -498,7 +498,7 @@ package body Tbuild is
Get_Name_String (Related_Id);
if Prefix /= ' ' then
pragma Assert (Is_OK_Internal_Letter (Prefix));
pragma Assert (Is_OK_Internal_Letter (Prefix) or else Prefix = '_');
for J in reverse 1 .. Name_Len loop
Name_Buffer (J + 1) := Name_Buffer (J);