From f9e0c415043f24d2d50272f6fd520e21fdc1eaf6 Mon Sep 17 00:00:00 2001 From: charlet Date: Thu, 1 Sep 2011 10:33:43 +0000 Subject: [PATCH] 2011-09-01 Ed Schonberg * exp_attr.adb, sem_attr.adb, snames.ads-tmpl: Implementation of attributes Same_Storage and Overlaps_Storage. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@178399 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 5 ++ gcc/ada/exp_attr.adb | 161 ++++++++++++++++++++++++++++++++++++++++++++++++ gcc/ada/sem_attr.adb | 44 +++++++++++++ gcc/ada/snames.ads-tmpl | 4 ++ 4 files changed, 214 insertions(+) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 4188b55..936a209 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,8 @@ +2011-09-01 Ed Schonberg + + * exp_attr.adb, sem_attr.adb, snames.ads-tmpl: Implementation of + attributes Same_Storage and Overlaps_Storage. + 2011-09-01 Hristian Kirtchev * exp_strm.adb: Remove with and use clause for Opt. diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index c03a040..c38a384 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -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 -- ------------- diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 4b2e0c2..119f6df 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -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 -- ----------- diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 964e516..3fa0166 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -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, -- 2.7.4