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

exp_attr.adb, [...]: Implementation of attributes Same_Storage and Overlaps_Storage.

Browse Source 
2011-09-01  Ed Schonberg  <schonberg@adacore.com>

	* exp_attr.adb, sem_attr.adb, snames.ads-tmpl: Implementation of
	attributes Same_Storage and Overlaps_Storage.

From-SVN: r178399
This commit is contained in:
Ed Schonberg 2011-09-01 10:33:43 +00:00 committed by Arnaud Charlet
parent 579fda569d
commit 2d42e8812e
4 changed files with 214 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
gcc/ada/ChangeLog
View File

@ -1,3 +1,8 @@
2011-09-01 Ed Schonberg <schonberg@adacore.com>
* exp_attr.adb, sem_attr.adb, snames.ads-tmpl: Implementation of
attributes Same_Storage and Overlaps_Storage.
2011-09-01 Hristian Kirtchev <kirtchev@adacore.com>
* exp_strm.adb: Remove with and use clause for Opt.

161
gcc/ada/exp_attr.adb
View File

@ -3091,6 +3091,100 @@ package body Exp_Attr is
Rewrite (N, New_Occurrence_Of (Tnn, Loc));
end Old;
----------------------
-- Overlaps_Storage --
----------------------
when Attribute_Overlaps_Storage => Overlaps_Storage : declare
Loc : constant Source_Ptr := Sloc (N);
X : constant Node_Id := Prefix (N);
Y : constant Node_Id := First (Expressions (N));
-- The argumens
X_Addr, Y_Addr : Node_Id;
-- the expressions for their integer addresses
X_Size, Y_Size : Node_Id;
-- the expressions for their sizes
Cond : Node_Id;
begin
-- Attribute expands into:
-- if X'Address < Y'address then
-- (X'address + X'Size - 1) >= Y'address
-- else
-- (Y'address + Y'size - 1) >= X'Address
-- end if;
-- with the proper address operations. We convert addresses to
-- integer addresses to use predefined arithmetic. The size is
-- expressed in storage units.
X_Addr :=
Unchecked_Convert_To (RTE (RE_Integer_Address),
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Address,
Prefix => New_Copy_Tree (X)));
Y_Addr :=
Unchecked_Convert_To (RTE (RE_Integer_Address),
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Address,
Prefix => New_Copy_Tree (Y)));
X_Size :=
Make_Op_Divide (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Size,
Prefix => New_Copy_Tree (X)),
Right_Opnd =>
Make_Integer_Literal (Loc, System_Storage_Unit));
Y_Size :=
Make_Op_Divide (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Size,
Prefix => New_Copy_Tree (Y)),
Right_Opnd =>
Make_Integer_Literal (Loc, System_Storage_Unit));
Cond :=
Make_Op_Le (Loc,
Left_Opnd => X_Addr,
Right_Opnd => Y_Addr);
Rewrite (N,
Make_Conditional_Expression (Loc,
New_List (
Cond,
Make_Op_Ge (Loc,
Left_Opnd =>
Make_Op_Add (Loc,
Left_Opnd => X_Addr,
Right_Opnd =>
Make_Op_Subtract (Loc,
Left_Opnd => X_Size,
Right_Opnd => Make_Integer_Literal (Loc, 1))),
Right_Opnd => Y_Addr),
Make_Op_Ge (Loc,
Make_Op_Add (Loc,
Left_Opnd => Y_Addr,
Right_Opnd =>
Make_Op_Subtract (Loc,
Left_Opnd => Y_Size,
Right_Opnd => Make_Integer_Literal (Loc, 1))),
Right_Opnd => X_Addr))));
Analyze_And_Resolve (N, Standard_Boolean);
end Overlaps_Storage;
------------
-- Output --
------------
@ -3916,6 +4010,73 @@ package body Exp_Attr is
when Attribute_Rounding =>
Expand_Fpt_Attribute_R (N);
------------------
-- Same_Storage --
------------------
when Attribute_Same_Storage => Same_Storage : declare
Loc : constant Source_Ptr := Sloc (N);
X : constant Node_Id := Prefix (N);
Y : constant Node_Id := First (Expressions (N));
-- The argumens
X_Addr, Y_Addr : Node_Id;
-- the expressions for their addresses
X_Size, Y_Size : Node_Id;
-- the expressions for their sizes
begin
-- The attribute is expanded as:
-- (X'address = Y'address)
-- and then (X'Size = Y'Size)
-- If both arguments have the same Etype the second conjunct can be
-- omitted.
X_Addr :=
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Address,
Prefix => New_Copy_Tree (X));
Y_Addr :=
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Address,
Prefix => New_Copy_Tree (Y));
X_Size :=
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Size,
Prefix => New_Copy_Tree (X));
Y_Size :=
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Size,
Prefix => New_Copy_Tree (Y));
if Etype (X) = Etype (Y) then
Rewrite (N,
(Make_Op_Eq (Loc,
Left_Opnd => X_Addr,
Right_Opnd => Y_Addr)));
else
Rewrite (N,
Make_Op_And (Loc,
Left_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd => X_Addr,
Right_Opnd => Y_Addr),
Right_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd => X_Size,
Right_Opnd => Y_Size)));
end if;
Analyze_And_Resolve (N, Standard_Boolean);
end Same_Storage;
-------------
-- Scaling --
-------------

44
gcc/ada/sem_attr.adb
View File

@ -3878,6 +3878,21 @@ package body Sem_Attr is
Expand (N);
end if;
----------------------
-- Overlaps_Storage --
----------------------
when Attribute_Overlaps_Storage =>
Check_E1;
-- Both arguments must be objects of any type
Analyze_And_Resolve (P);
Analyze_And_Resolve (E1);
Check_Object_Reference (P);
Check_Object_Reference (E1);
Set_Etype (N, Standard_Boolean);
------------
-- Output --
------------
@ -4354,6 +4369,21 @@ package body Sem_Attr is
Check_Real_Type;
Set_Etype (N, Universal_Real);
------------------
-- Same_Storage --
------------------
when Attribute_Same_Storage =>
Check_E1;
-- The arguments must be objects of any type
Analyze_And_Resolve (P);
Analyze_And_Resolve (E1);
Check_Object_Reference (P);
Check_Object_Reference (E1);
Set_Etype (N, Standard_Boolean);
-----------
-- Scale --
-----------
@ -6911,6 +6941,13 @@ package body Sem_Attr is
end if;
end Object_Size;
----------------------
-- Overlaps_Storage --
----------------------
when Attribute_Overlaps_Storage =>
null;
-------------------------
-- Passed_By_Reference --
-------------------------
@ -7140,6 +7177,13 @@ package body Sem_Attr is
Fold_Ureal (N, Model_Small_Value (P_Type), Static);
end if;
------------------
-- Same_Storage --
------------------
when Attribute_Same_Storage =>
null;
-----------
-- Scale --
-----------

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

@ -792,6 +792,7 @@ package Snames is
Name_Null_Parameter : constant Name_Id := N + $; -- GNAT
Name_Object_Size : constant Name_Id := N + $; -- GNAT
Name_Old : constant Name_Id := N + $; -- GNAT
Name_Overlaps_Storage : constant Name_Id := N + $; -- GNAT
Name_Partition_ID : constant Name_Id := N + $;
Name_Passed_By_Reference : constant Name_Id := N + $; -- GNAT
Name_Pool_Address : constant Name_Id := N + $;
@ -808,6 +809,7 @@ package Snames is
Name_Safe_Large : constant Name_Id := N + $; -- Ada 83
Name_Safe_Last : constant Name_Id := N + $;
Name_Safe_Small : constant Name_Id := N + $; -- Ada 83
Name_Same_Storage : constant Name_Id := N + $; -- Ada 12
Name_Scale : constant Name_Id := N + $;
Name_Scaling : constant Name_Id := N + $;
Name_Signed_Zeros : constant Name_Id := N + $;
@ -1344,6 +1346,7 @@ package Snames is
Attribute_Null_Parameter,
Attribute_Object_Size,
Attribute_Old,
Attribute_Overlaps_Storage,
Attribute_Partition_ID,
Attribute_Passed_By_Reference,
Attribute_Pool_Address,
@ -1360,6 +1363,7 @@ package Snames is
Attribute_Safe_Large,
Attribute_Safe_Last,
Attribute_Safe_Small,
Attribute_Same_Storage,
Attribute_Scale,
Attribute_Scaling,
Attribute_Signed_Zeros,