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

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

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 4188b5597db8b1775d097946a2573cdc456a06a3..936a2090649e81779fe10b9f4bd7519c5a894e87 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -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.

diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index c03a040fdaf2d5de9520aa3091b2920b5471614c..c38a3844a78b35806ad378e699f64a6e797e8e58 100644 (file)
--- 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 4b2e0c236a32e8eafd90e680f6edbe1afe7cdc10..119f6df3e0de808edf7641b69cc26d8cd046a15b 100644 (file)
--- 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 964e516bc62a6451f930d565b413d18b0f827f84..3fa0166b66d351e0eef1af4e2dfd7344c513c77c 100644 (file)
--- 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,