OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

exp_attr.adb (Expand_N_Attribute_Reference): Case Callable and Terminated... 

2007-04-20  Hristian Kirtchev  <kirtchev@adacore.com>
	    Javier Miranda  <miranda@adacore.com>
	    Robert Dewar  <dewar@adacore.com>

	* exp_attr.adb (Expand_N_Attribute_Reference): Case Callable and
	Terminated: Add unchecked type conversion from System.Address to
	System.Tasking.Task_Id when calling the predefined primitive
	_disp_get_task_id.
	Disable new Ada 05 accessibility check for JVM.NET targets, which
	cannot be implemented in a practical way.
	(Expand_N_Attribute_Reference: case Attribute_Tag): The use of 'Tag in
	the sources always references the tag of the actual object. Therefore,
	if 'Tag is applied in the sources to class-wide interface objects we
	generate code that displaces "this" to reference the base of the object.
	(Expand_N_Attribute_Reference, case Size): Return specified size if
	known to front end.
	(Expand_N_Attribute_Reference): The expansion of the 'Address attribute
	has code that displaces the pointer of the object to manage interface
	types. However this code must not be executed when the prefix is a
	subprogram. This bug caused the wrong expansion of the internally
	generated assignment that fills the dispatch table when the primitive
	is a function returning a class-wide interface type.
	(Expand_N_Attribute_Reference:Attribute_Valid): Remove incorrect call to
	Set_Attribute_Name for Name_Unaligned_Valid.

From-SVN: r125393
This commit is contained in:
Hristian Kirtchev 2007-06-06 12:24:07 +02:00 committed by Arnaud Charlet
parent 0f95b17845
commit 31104818b7
1 changed files with 114 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

160
gcc/ada/exp_attr.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, 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- --
@ -38,7 +38,6 @@ with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Exp_VFpt; use Exp_VFpt;
with Gnatvsn; use Gnatvsn;
with Hostparm; use Hostparm;
with Lib; use Lib;
with Namet; use Namet;
with Nmake; use Nmake;
@ -57,6 +56,7 @@ with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Uintp; use Uintp;
@ -186,7 +186,7 @@ package body Exp_Attr is
and then not In_Open_Scopes (Scop)
and then Ekind (Scop) = E_Package
then
New_Scope (Scop);
Push_Scope (Scop);
Install_Visible_Declarations (Scop);
Install_Private_Declarations (Scop);
Installed := True;
@ -196,7 +196,7 @@ package body Exp_Attr is
-- enclosing stream function) so that itypes all have their proper
-- scopes.
New_Scope (Curr);
Push_Scope (Curr);
end if;
if Check then
@ -810,7 +810,9 @@ package body Exp_Attr is
-- address of the object.
elsif Is_Class_Wide_Type (Etype (Pref))
and then Is_Interface (Etype (Pref))
and then Is_Interface (Etype (Pref))
and then not (Nkind (Pref) in N_Has_Entity
and then Is_Subprogram (Entity (Pref)))
then
Rewrite (N,
Make_Function_Call (Loc,
@ -1119,11 +1121,11 @@ package body Exp_Attr is
-- We have an object of a task interface class-wide type as a prefix
-- to Callable. Generate:
-- callable (Pref._disp_get_task_id);
-- callable (Task_Id (Pref._disp_get_task_id));
if Ada_Version >= Ada_05
and then Ekind (Etype (Pref)) = E_Class_Wide_Type
and then Is_Interface (Etype (Pref))
and then Is_Interface (Etype (Pref))
and then Is_Task_Interface (Etype (Pref))
then
Rewrite (N,
@ -1131,11 +1133,16 @@ package body Exp_Attr is
Name =>
New_Reference_To (RTE (RE_Callable), Loc),
Parameter_Associations => New_List (
Make_Selected_Component (Loc,
Prefix =>
New_Copy_Tree (Pref),
Selector_Name =>
Make_Identifier (Loc, Name_uDisp_Get_Task_Id)))));
Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark =>
New_Reference_To (RTE (RO_ST_Task_Id), Loc),
Expression =>
Make_Selected_Component (Loc,
Prefix =>
New_Copy_Tree (Pref),
Selector_Name =>
Make_Identifier (Loc, Name_uDisp_Get_Task_Id))))));
else
Rewrite (N,
Build_Call_With_Task (Pref, RTE (RE_Callable)));
@ -1534,12 +1541,15 @@ package body Exp_Attr is
if Nkind (Nod) = N_Selected_Component then
Make_Elab_String (Prefix (Nod));
if Java_VM then
Store_String_Char ('$');
else
Store_String_Char ('_');
Store_String_Char ('_');
end if;
case VM_Target is
when JVM_Target =>
Store_String_Char ('$');
when CLI_Target =>
Store_String_Char ('.');
when No_VM =>
Store_String_Char ('_');
Store_String_Char ('_');
end case;
Get_Name_String (Chars (Selector_Name (Nod)));
@ -1560,12 +1570,12 @@ package body Exp_Attr is
Start_String;
Make_Elab_String (Pref);
if Java_VM then
Store_String_Chars ("._elab");
Lang := Make_Identifier (Loc, Name_Ada);
else
if VM_Target = No_VM then
Store_String_Chars ("___elab");
Lang := Make_Identifier (Loc, Name_C);
else
Store_String_Chars ("._elab");
Lang := Make_Identifier (Loc, Name_Ada);
end if;
if Id = Attribute_Elab_Body then
@ -2717,7 +2727,7 @@ package body Exp_Attr is
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Wfunc, Loc),
Parameter_Associations => New_List (
Convert_To (Etype (First_Formal (Wfunc)),
OK_Convert_To (Etype (First_Formal (Wfunc)),
Relocate_Node (Next (First (Exprs)))))))));
Analyze (N);
@ -2770,19 +2780,24 @@ package body Exp_Attr is
Item : constant Node_Id := Next (Strm);
begin
-- The code is:
-- Ada 2005 (AI-344): Check that the accessibility level
-- of the type of the output object is not deeper than
-- that of the attribute's prefix type.
-- if Get_Access_Level (Item'Tag)
-- /= Get_Access_Level (P_Type'Tag)
-- then
-- raise Tag_Error;
-- end if;
-- String'Output (Strm, External_Tag (Item'Tag));
-- Ada 2005 (AI-344): Check that the accessibility level
-- of the type of the output object is not deeper than
-- that of the attribute's prefix type.
-- We cannot figure out a practical way to implement this
-- accessibility check on virtual machines, so we omit it.
if Ada_Version >= Ada_05 then
if Ada_Version >= Ada_05
and then VM_Target = No_VM
then
Insert_Action (N,
Make_Implicit_If_Statement (N,
Condition =>
@ -3232,7 +3247,7 @@ package body Exp_Attr is
Rfunc := Entity (Expression (Arg2));
Lhs := Relocate_Node (Next (First (Exprs)));
Rhs :=
Convert_To (B_Type,
OK_Convert_To (B_Type,
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Rfunc, Loc),
Parameter_Associations => New_List (
@ -3532,7 +3547,35 @@ package body Exp_Attr is
Rewrite (N, New_Node);
Analyze_And_Resolve (N, Typ);
return;
return;
-- Case of known RM_Size of a type
elsif (Id = Attribute_Size or else Id = Attribute_Value_Size)
and then Is_Entity_Name (Pref)
and then Is_Type (Entity (Pref))
and then Known_Static_RM_Size (Entity (Pref))
then
Siz := RM_Size (Entity (Pref));
-- Case of known Esize of a type
elsif Id = Attribute_Object_Size
and then Is_Entity_Name (Pref)
and then Is_Type (Entity (Pref))
and then Known_Static_Esize (Entity (Pref))
then
Siz := Esize (Entity (Pref));
-- Case of known size of object
elsif Id = Attribute_Size
and then Is_Entity_Name (Pref)
and then Is_Object (Entity (Pref))
and then Known_Esize (Entity (Pref))
and then Known_Static_Esize (Entity (Pref))
then
Siz := Esize (Entity (Pref));
-- For an array component, we can do Size in the front end
-- if the component_size of the array is set.
@ -3583,10 +3626,9 @@ package body Exp_Attr is
Analyze_And_Resolve (N, Typ);
end if;
-- If Size is applied to a dereference of an access to
-- unconstrained packed array, GIGI needs to see its
-- unconstrained nominal type, but also a hint to the actual
-- constrained type.
-- If Size applies to a dereference of an access to unconstrained
-- packed array, GIGI needs to see its unconstrained nominal type,
-- but also a hint to the actual constrained type.
if Nkind (Pref) = N_Explicit_Dereference
and then Is_Array_Type (Etype (Pref))
@ -3602,7 +3644,7 @@ package body Exp_Attr is
-- Common processing for record and array component case
if Siz /= 0 then
if Siz /= No_Uint and then Siz /= 0 then
Rewrite (N, Make_Integer_Literal (Loc, Siz));
Analyze_And_Resolve (N, Typ);
@ -3896,10 +3938,10 @@ package body Exp_Attr is
if Prefix_Is_Type then
-- For JGNAT we leave the type attribute unexpanded because
-- For VMs we leave the type attribute unexpanded because
-- there's not a dispatching table to reference.
if not Java_VM then
if VM_Target = No_VM then
Rewrite (N,
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To
@ -3907,6 +3949,29 @@ package body Exp_Attr is
Analyze_And_Resolve (N, RTE (RE_Tag));
end if;
-- (Ada 2005 (AI-251): The use of 'Tag in the sources always
-- references the primary tag of the actual object. If 'Tag is
-- applied to class-wide interface objects we generate code that
-- displaces "this" to reference the base of the object.
elsif Comes_From_Source (N)
and then Is_Class_Wide_Type (Etype (Prefix (N)))
and then Is_Interface (Etype (Prefix (N)))
then
-- Generate:
-- (To_Tag_Ptr (Prefix'Address)).all
-- Note that Prefix'Address is recursively expanded into a call
-- to Base_Address (Obj.Tag)
Rewrite (N,
Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (RTE (RE_Tag_Ptr),
Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (Pref),
Attribute_Name => Name_Address))));
Analyze_And_Resolve (N, RTE (RE_Tag));
else
Rewrite (N,
Make_Selected_Component (Loc,
@ -3928,11 +3993,11 @@ package body Exp_Attr is
-- The prefix of Terminated is of a task interface class-wide type.
-- Generate:
-- terminated (Pref._disp_get_task_id);
-- terminated (Task_Id (Pref._disp_get_task_id));
if Ada_Version >= Ada_05
and then Ekind (Etype (Pref)) = E_Class_Wide_Type
and then Is_Interface (Etype (Pref))
and then Is_Interface (Etype (Pref))
and then Is_Task_Interface (Etype (Pref))
then
Rewrite (N,
@ -3940,11 +4005,15 @@ package body Exp_Attr is
Name =>
New_Reference_To (RTE (RE_Terminated), Loc),
Parameter_Associations => New_List (
Make_Selected_Component (Loc,
Prefix =>
New_Copy_Tree (Pref),
Selector_Name =>
Make_Identifier (Loc, Name_uDisp_Get_Task_Id)))));
Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark =>
New_Reference_To (RTE (RO_ST_Task_Id), Loc),
Expression =>
Make_Selected_Component (Loc,
Prefix =>
New_Copy_Tree (Pref),
Selector_Name =>
Make_Identifier (Loc, Name_uDisp_Get_Task_Id))))));
elsif Restricted_Profile then
Rewrite (N,
@ -4257,7 +4326,6 @@ package body Exp_Attr is
-- obj'Address (see Unaligned_Valid routine in Fat_Gen).
if Is_Possibly_Unaligned_Object (Pref) then
Set_Attribute_Name (N, Name_Unaligned_Valid);
Expand_Fpt_Attribute
(N, Pkg, Name_Unaligned_Valid,
New_List (
@ -4702,7 +4770,7 @@ package body Exp_Attr is
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Wfunc, Loc),
Parameter_Associations => New_List (
Convert_To (Etype (First_Formal (Wfunc)),
OK_Convert_To (Etype (First_Formal (Wfunc)),
Relocate_Node (Next (First (Exprs)))))))));
Analyze (N);