mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-24 13:11:44 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2011-12-12  Robert Dewar  <dewar@adacore.com>

	* sem_prag.adb (GNAT_Pragma): Check comes from source.

2011-12-12  Robert Dewar  <dewar@adacore.com>

	* gnatls.adb: Minor reformatting.

2011-12-12  Javier Miranda  <miranda@adacore.com>

	* a-tags.ads (Alignment): New TSD field.
	(Max_Predef_Prims): Value lowered to 15 (or 9 in case of
	configurable runtime) Update documentation of predefined
	primitives since Alignment has been removed.
	* exp_disp.ads Update documentation of slots of dispatching
	primitives.
	* exp_disp.adb (Default_Prim_Op_Position): Update slot
	values since alignment is no longer a predefined primitive.
	(Is_Predefined_Dispatch_Operation): Remove _alignment.
	(Is_Predefined_Internal_Operation): Remove _alignment.
	(Make_DT): Update static test on the value stored in a-tags.ads
	for Max_Predef_Prims; store the value of 'alignment in the TSD.
	* exp_atag.ads, exp_atag.adb (Build_Get_Alignment): New subprogram
	that retrieves the alignment from the TSD
	* exp_util.adb (Build_Allocated_Deallocate_Proc): For deallocation
	of class-wide types obtain the value of alignment from the TSD.
	* exp_attr.adb (Expand_N_Attribute_Reference): For 'alignment
	applied to a class-wide type invoke Build_Get_Alignment to
	generate code which retrieves the value of the alignment from
	the TSD.
	* rtsfind.ads (RE_Alignment): New Ada.Tags entity
	* sem_ch13.adb (Analyze_Attribute_Definition_Clause): For tagged
	types if the value of the alignment is bigger than the Maximum
	alignment then set the value of the alignment to the Maximum
	alignment and report a warning.
	* exp_ch3.adb (Make_Predefined_Primitive_Specs): Do not generate
	spec of _alignment.
	(Predefined_Primitive_Bodies): Do not generate body of _alignment.

From-SVN: r182229
This commit is contained in:
Arnaud Charlet 2011-12-12 12:54:30 +01:00
parent fe58fea70b
commit 6bed26b542
13 changed files with 186 additions and 111 deletions

39
gcc/ada/ChangeLog

@ -1,3 +1,42 @@
2011-12-12 Robert Dewar <dewar@adacore.com>
* sem_prag.adb (GNAT_Pragma): Check comes from source.
2011-12-12 Robert Dewar <dewar@adacore.com>
* gnatls.adb: Minor reformatting.
2011-12-12 Javier Miranda <miranda@adacore.com>
* a-tags.ads (Alignment): New TSD field.
(Max_Predef_Prims): Value lowered to 15 (or 9 in case of
configurable runtime) Update documentation of predefined
primitives since Alignment has been removed.
* exp_disp.ads Update documentation of slots of dispatching
primitives.
* exp_disp.adb (Default_Prim_Op_Position): Update slot
values since alignment is no longer a predefined primitive.
(Is_Predefined_Dispatch_Operation): Remove _alignment.
(Is_Predefined_Internal_Operation): Remove _alignment.
(Make_DT): Update static test on the value stored in a-tags.ads
for Max_Predef_Prims; store the value of 'alignment in the TSD.
* exp_atag.ads, exp_atag.adb (Build_Get_Alignment): New subprogram
that retrieves the alignment from the TSD
* exp_util.adb (Build_Allocated_Deallocate_Proc): For deallocation
of class-wide types obtain the value of alignment from the TSD.
* exp_attr.adb (Expand_N_Attribute_Reference): For 'alignment
applied to a class-wide type invoke Build_Get_Alignment to
generate code which retrieves the value of the alignment from
the TSD.
* rtsfind.ads (RE_Alignment): New Ada.Tags entity
* sem_ch13.adb (Analyze_Attribute_Definition_Clause): For tagged
types if the value of the alignment is bigger than the Maximum
alignment then set the value of the alignment to the Maximum
alignment and report a warning.
* exp_ch3.adb (Make_Predefined_Primitive_Specs): Do not generate
spec of _alignment.
(Predefined_Primitive_Bodies): Do not generate body of _alignment.
2011-12-12 Gary Dismukes <dismukes@adacore.com>
* freeze.adb (Freeze_Expression): Allow freezing of static

34
gcc/ada/a-tags.ads

@ -98,6 +98,8 @@ private
-- : primitive ops : +-------------------+
-- | pointers | | access level |
-- +--------------------+ +-------------------+
-- | alignment |
-- +-------------------+
-- | expanded name |
-- +-------------------+
-- | external tag |
@ -269,6 +271,7 @@ private
-- function return, and class-wide stream I/O, the danger of objects
-- outliving their type declaration can be eliminated (Ada 2005: AI-344)
Alignment : Natural;
Expanded_Name : Cstring_Ptr;
External_Tag : Cstring_Ptr;
HT_Link : Tag_Ptr;
@ -545,25 +548,24 @@ private
procedure Unregister_Tag (T : Tag);
-- Remove a particular tag from the external tag hash table
Max_Predef_Prims : constant Positive := 16;
Max_Predef_Prims : constant Positive := 15;
-- Number of reserved slots for the following predefined ada primitives:
--
-- 1. Size
-- 2. Alignment,
-- 3. Read
-- 4. Write
-- 5. Input
-- 6. Output
-- 7. "="
-- 8. assignment
-- 9. deep adjust
-- 10. deep finalize
-- 11. async select
-- 12. conditional select
-- 13. prim_op kind
-- 14. task_id
-- 15. dispatching requeue
-- 16. timed select
-- 2. Read
-- 3. Write
-- 4. Input
-- 5. Output
-- 6. "="
-- 7. assignment
-- 8. deep adjust
-- 9. deep finalize
-- 10. async select
-- 11. conditional select
-- 12. prim_op kind
-- 13. task_id
-- 14. dispatching requeue
-- 15. timed select
--
-- The compiler checks that the value here is correct

19
gcc/ada/exp_atag.adb

@ -289,6 +289,25 @@ package body Exp_Atag is
(RTE_Record_Component (RE_Access_Level), Loc));
end Build_Get_Access_Level;
-------------------------
-- Build_Get_Alignment --
-------------------------
function Build_Get_Alignment
(Loc : Source_Ptr;
Tag_Node : Node_Id) return Node_Id
is
begin
return
Make_Selected_Component (Loc,
Prefix =>
Build_TSD (Loc,
Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Alignment), Loc));
end Build_Get_Alignment;
------------------------------------------
-- Build_Get_Predefined_Prim_Op_Address --
------------------------------------------

7
gcc/ada/exp_atag.ads

@ -66,6 +66,13 @@ package Exp_Atag is
--
-- Generates: TSD (Tag).Access_Level
function Build_Get_Alignment
(Loc : Source_Ptr;
Tag_Node : Node_Id) return Node_Id;
-- Build code that retrieves the alignment of the tagged type.
--
-- Generates: TSD (Tag).Alignment
procedure Build_Get_Predefined_Prim_Op_Address
(Loc : Source_Ptr;
Position : Uint;

16
gcc/ada/exp_attr.adb

@ -1120,19 +1120,11 @@ package body Exp_Attr is
elsif Is_Class_Wide_Type (Ptyp) then
-- No need to do anything else compiling under restriction
-- No_Dispatching_Calls. During the semantic analysis we
-- already notified such violation.
if Restriction_Active (No_Dispatching_Calls) then
return;
end if;
New_Node :=
Make_Function_Call (Loc,
Name => New_Reference_To
(Find_Prim_Op (Ptyp, Name_uAlignment), Loc),
Parameter_Associations => New_List (Pref));
Build_Get_Alignment (Loc,
Make_Attribute_Reference (Loc,
Prefix => Pref,
Attribute_Name => Name_Tag));
if Typ /= Standard_Integer then

36
gcc/ada/exp_ch3.adb

@ -250,7 +250,6 @@ package body Exp_Ch3 is
-- Dispatching is required in general, since the result of the attribute
-- will vary with the actual object subtype.
--
-- _alignment provides result of 'Alignment attribute
-- _size provides result of 'Size attribute
-- typSR provides result of 'Read attribute
-- typSW provides result of 'Write attribute
@ -8156,18 +8155,6 @@ package body Exp_Ch3 is
Ret_Type => Standard_Long_Long_Integer));
-- Spec of _Alignment
Append_To (Res, Predef_Spec_Or_Body (Loc,
Tag_Typ => Tag_Typ,
Name => Name_uAlignment,
Profile => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
Ret_Type => Standard_Integer));
-- Specs for dispatching stream attributes
declare
@ -8740,29 +8727,6 @@ package body Exp_Ch3 is
end loop;
end if;
-- Body of _Alignment
Decl := Predef_Spec_Or_Body (Loc,
Tag_Typ => Tag_Typ,
Name => Name_uAlignment,
Profile => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
Ret_Type => Standard_Integer,
For_Body => True);
Set_Handled_Statement_Sequence (Decl,
Make_Handled_Sequence_Of_Statements (Loc, New_List (
Make_Simple_Return_Statement (Loc,
Expression =>
Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, Name_X),
Attribute_Name => Name_Alignment)))));
Append_To (Res, Decl);
-- Body of _Size
Decl := Predef_Spec_Or_Body (Loc,

57
gcc/ada/exp_disp.adb

@ -579,32 +579,29 @@ package body Exp_Disp is
if Chars (E) = Name_uSize then
return Uint_1;
elsif Chars (E) = Name_uAlignment then
elsif TSS_Name = TSS_Stream_Read then
return Uint_2;
elsif TSS_Name = TSS_Stream_Read then
elsif TSS_Name = TSS_Stream_Write then
return Uint_3;
elsif TSS_Name = TSS_Stream_Write then
elsif TSS_Name = TSS_Stream_Input then
return Uint_4;
elsif TSS_Name = TSS_Stream_Input then
elsif TSS_Name = TSS_Stream_Output then
return Uint_5;
elsif TSS_Name = TSS_Stream_Output then
elsif Chars (E) = Name_Op_Eq then
return Uint_6;
elsif Chars (E) = Name_Op_Eq then
elsif Chars (E) = Name_uAssign then
return Uint_7;
elsif Chars (E) = Name_uAssign then
elsif TSS_Name = TSS_Deep_Adjust then
return Uint_8;
elsif TSS_Name = TSS_Deep_Adjust then
return Uint_9;
elsif TSS_Name = TSS_Deep_Finalize then
return Uint_10;
return Uint_9;
-- In VM targets unconditionally allow obtaining the position associated
-- with predefined interface primitives since in these platforms any
@ -612,22 +609,22 @@ package body Exp_Disp is
elsif Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion then
if Chars (E) = Name_uDisp_Asynchronous_Select then
return Uint_11;
return Uint_10;
elsif Chars (E) = Name_uDisp_Conditional_Select then
return Uint_12;
return Uint_11;
elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then
return Uint_13;
return Uint_12;
elsif Chars (E) = Name_uDisp_Get_Task_Id then
return Uint_14;
return Uint_13;
elsif Chars (E) = Name_uDisp_Requeue then
return Uint_15;
return Uint_14;
elsif Chars (E) = Name_uDisp_Timed_Select then
return Uint_16;
return Uint_15;
end if;
end if;
@ -1945,7 +1942,6 @@ package body Exp_Disp is
TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1
.. Name_Len));
if Chars (E) = Name_uSize
or else Chars (E) = Name_uAlignment
or else TSS_Name = TSS_Stream_Read
or else TSS_Name = TSS_Stream_Write
or else TSS_Name = TSS_Stream_Input
@ -1991,7 +1987,6 @@ package body Exp_Disp is
(Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
if Chars (E) = Name_uSize
or else Chars (E) = Name_uAlignment
or else
(Chars (E) = Name_Op_Eq
and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
@ -4513,16 +4508,16 @@ package body Exp_Disp is
end if;
-- Ensure that the value of Max_Predef_Prims defined in a-tags is
-- correct. Valid values are 10 under configurable runtime or 16
-- correct. Valid values are 9 under configurable runtime or 15
-- with full runtime.
if RTE_Available (RE_Interface_Data) then
if Max_Predef_Prims /= 16 then
if Max_Predef_Prims /= 15 then
Error_Msg_N ("run-time library configuration error", Typ);
return Result;
end if;
else
if Max_Predef_Prims /= 10 then
if Max_Predef_Prims /= 9 then
Error_Msg_N ("run-time library configuration error", Typ);
Error_Msg_CRT ("tagged types", Typ);
return Result;
@ -4846,6 +4841,7 @@ package body Exp_Disp is
-- TSD : Type_Specific_Data (I_Depth) :=
-- (Idepth => I_Depth,
-- Access_Level => Type_Access_Level (Typ),
-- Alignment => Typ'Alignment,
-- Expanded_Name => Cstring_Ptr!(Exname'Address))
-- External_Tag => Cstring_Ptr!(Exname'Address))
-- HT_Link => HT_Link'Address,
@ -4895,6 +4891,23 @@ package body Exp_Disp is
Append_To (TSD_Aggr_List,
Make_Integer_Literal (Loc, Type_Access_Level (Typ)));
-- Alignment
-- For CPP types we cannot rely on the value of 'Alignment provided
-- by the backend to initialize this TSD field.
if Convention (Typ) = Convention_CPP
or else Is_CPP_Class (Root_Type (Typ))
then
Append_To (TSD_Aggr_List,
Make_Integer_Literal (Loc, 0));
else
Append_To (TSD_Aggr_List,
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Typ, Loc),
Attribute_Name => Name_Alignment));
end if;
-- Expanded_Name
Append_To (TSD_Aggr_List,

32
gcc/ada/exp_disp.ads

@ -52,65 +52,61 @@ package Exp_Disp is
-- type. Constructs of the form Prefix'Size are converted into
-- Prefix._Size.
-- _Alignment (2) - implementation of the attribute 'Alignment for
-- any tagged type. Constructs of the form Prefix'Alignment are
-- converted into Prefix._Alignment.
-- TSS_Stream_Read (3) - implementation of the stream attribute Read
-- TSS_Stream_Read (2) - implementation of the stream attribute Read
-- for any tagged type.
-- TSS_Stream_Write (4) - implementation of the stream attribute Write
-- TSS_Stream_Write (3) - implementation of the stream attribute Write
-- for any tagged type.
-- TSS_Stream_Input (5) - implementation of the stream attribute Input
-- TSS_Stream_Input (4) - implementation of the stream attribute Input
-- for any tagged type.
-- TSS_Stream_Output (6) - implementation of the stream attribute
-- TSS_Stream_Output (5) - implementation of the stream attribute
-- Output for any tagged type.
-- Op_Eq (7) - implementation of the equality operator for any non-
-- Op_Eq (6) - implementation of the equality operator for any non-
-- limited tagged type.
-- _Assign (8) - implementation of the assignment operator for any
-- _Assign (7) - implementation of the assignment operator for any
-- non-limited tagged type.
-- TSS_Deep_Adjust (9) - implementation of the finalization operation
-- TSS_Deep_Adjust (8) - implementation of the finalization operation
-- Adjust for any non-limited tagged type.
-- TSS_Deep_Finalize (10) - implementation of the finalization
-- TSS_Deep_Finalize (9) - implementation of the finalization
-- operation Finalize for any non-limited tagged type.
-- _Disp_Asynchronous_Select (11) - used in the expansion of ATC with
-- _Disp_Asynchronous_Select (10) - used in the expansion of ATC with
-- dispatching triggers. Null implementation for limited interfaces,
-- full body generation for types that implement limited interfaces,
-- not generated for the rest of the cases. See Expand_N_Asynchronous_
-- Select in Exp_Ch9 for more information.
-- _Disp_Conditional_Select (12) - used in the expansion of conditional
-- _Disp_Conditional_Select (11) - used in the expansion of conditional
-- selects with dispatching triggers. Null implementation for limited
-- interfaces, full body generation for types that implement limited
-- interfaces, not generated for the rest of the cases. See Expand_N_
-- Conditional_Entry_Call in Exp_Ch9 for more information.
-- _Disp_Get_Prim_Op_Kind (13) - helper routine used in the expansion
-- _Disp_Get_Prim_Op_Kind (12) - helper routine used in the expansion
-- of ATC with dispatching triggers. Null implementation for limited
-- interfaces, full body generation for types that implement limited
-- interfaces, not generated for the rest of the cases.
-- _Disp_Get_Task_Id (14) - helper routine used in the expansion of
-- _Disp_Get_Task_Id (13) - helper routine used in the expansion of
-- Abort, attributes 'Callable and 'Terminated for task interface
-- class-wide types. Full body generation for task types, null
-- implementation for limited interfaces, not generated for the rest
-- of the cases. See Expand_N_Attribute_Reference in Exp_Attr and
-- Expand_N_Abort_Statement in Exp_Ch9 for more information.
-- _Disp_Requeue (15) - used in the expansion of dispatching requeue
-- _Disp_Requeue (14) - used in the expansion of dispatching requeue
-- statements. Null implementation is provided for protected, task
-- and synchronized interfaces. Protected and task types implementing
-- concurrent interfaces receive full bodies. See Expand_N_Requeue_
-- Statement in Exp_Ch9 for more information.
-- _Disp_Timed_Select (16) - used in the expansion of timed selects
-- _Disp_Timed_Select (15) - used in the expansion of timed selects
-- with dispatching triggers. Null implementation for limited
-- interfaces, full body generation for types that implement limited
-- interfaces, not generated for the rest of the cases. See Expand_N_

27
gcc/ada/exp_util.adb

@ -755,7 +755,32 @@ package body Exp_Util is
Append_To (Actuals, New_Reference_To (Addr_Id, Loc));
Append_To (Actuals, New_Reference_To (Size_Id, Loc));
Append_To (Actuals, New_Reference_To (Alig_Id, Loc));
if Is_Allocate
or else not Is_Class_Wide_Type (Desig_Typ)
then
Append_To (Actuals, New_Reference_To (Alig_Id, Loc));
-- For deallocation of class wide types we obtain the value of
-- alignment from the Type Specific Record of the deallocated object.
-- This is needed because the frontend expansion of class-wide types
-- into equivalent types confuses the backend.
else
-- Generate:
-- Obj.all'Alignment
-- ... because 'Alignment applied to class-wide types is expanded
-- into the code that reads the value of alignment from the TSD
-- (see Expand_N_Attribute_Reference)
Append_To (Actuals,
Unchecked_Convert_To (RTE (RE_Storage_Offset),
Make_Attribute_Reference (Loc,
Prefix =>
Make_Explicit_Dereference (Loc, Relocate_Node (Expr)),
Attribute_Name => Name_Alignment)));
end if;
-- h) Is_Controlled

4
gcc/ada/gnatls.adb

@ -1221,8 +1221,8 @@ procedure Gnatls is
if Rts_Full_Path /= null then
-- Directory name was found on the project path. Look for the
-- include subdir(s).
-- Directory name was found on the project path. Look for the
-- include subdirectory(s).
Src_Path := Get_RTS_Search_Dir (Rts_Full_Path.all, Include);

2
gcc/ada/rtsfind.ads

@ -570,6 +570,7 @@ package Rtsfind is
RE_Unbounded_String, -- Ada.Strings.Unbounded
RE_Access_Level, -- Ada.Tags
RE_Alignment, -- Ada.Tags
RE_Address_Array, -- Ada.Tags
RE_Addr_Ptr, -- Ada.Tags
RE_Base_Address, -- Ada.Tags
@ -1768,6 +1769,7 @@ package Rtsfind is
RE_Unbounded_String => Ada_Strings_Unbounded,
RE_Access_Level => Ada_Tags,
RE_Alignment => Ada_Tags,
RE_Address_Array => Ada_Tags,
RE_Addr_Ptr => Ada_Tags,
RE_Base_Address => Ada_Tags,

15
gcc/ada/sem_ch13.adb

@ -2495,8 +2495,8 @@ package body Sem_Ch13 is
-- Alignment attribute definition clause
when Attribute_Alignment => Alignment : declare
Align : constant Uint := Get_Alignment_Value (Expr);
Align : constant Uint := Get_Alignment_Value (Expr);
Max_Align : constant Uint := UI_From_Int (Maximum_Alignment);
begin
FOnly := True;
@ -2511,7 +2511,16 @@ package body Sem_Ch13 is
elsif Align /= No_Uint then
Set_Has_Alignment_Clause (U_Ent);
Set_Alignment (U_Ent, Align);
if Is_Tagged_Type (U_Ent)
and then Align > Max_Align
then
Error_Msg_N
("?alignment for & set to Maximum_Aligment", Nam);
Set_Alignment (U_Ent, Max_Align);
else
Set_Alignment (U_Ent, Align);
end if;
-- For an array type, U_Ent is the first subtype. In that case,
-- also set the alignment of the anonymous base type so that

9
gcc/ada/sem_prag.adb

@ -2709,7 +2709,14 @@ package body Sem_Prag is
procedure GNAT_Pragma is
begin
Check_Restriction (No_Implementation_Pragmas, N);
-- We need to check the No_Implementation_Pragmas restriction for
-- the case of a pragma from source. Note that the case of aspects
-- generating corresponding pragmas marks these pragmas as not being
-- from source, so this test also catches that case.
if Comes_From_Source (N) then
Check_Restriction (No_Implementation_Pragmas, N);
end if;
end GNAT_Pragma;
--------------------------