ada: Remove the body of System.Storage_Elements

All the subprograms declared in the unit have convention Intrinsic and
their current implementation makes some implicit assumptions that are
not valid universally, so it is replaced by a direct expansion.

This is mostly straightforward because Resolve_Intrinsic_Operator already
contains the required circuitry, but a few adjustements are necessary.

gcc/ada/

	* exp_ch4.adb (Expand_N_Op_Mod): Deal with the special mod
	operator of System.Storage_Elements.
	* exp_intr.adb (Expand_To_Integer): New procedure.
	(Expand_Intrinsic_Call): Call Expand_To_Integer appropriately.
	(Expand_To_Address): Deal with an argument with modular type.
	* sem_ch3.adb (Derive_Subprogram): Also set convention Intrinsic
	on a derived intrinsic subprogram.
	* sem_res.adb (Resolve_Arithmetic_Op): Deal with intrinsic
	operators not coming from source exactly as those coming from
	source and also generate a reference in both cases.
	(Resolve_Op_Expon): Likewise.
	(Resolve_Intrinsic_Operator): Call Implementation_Base_Type to get
	a nonprivate base type.
	* snames.ads-tmpl (Name_To_Integer): New intrinsic name.
	* libgnat/s-stoele.ads: Replace pragma Convention with pragma
	Import throughout and remove pragma Inline_Always and
	Pure_Function.
	* libgnat/s-stoele.adb: Replace entire contents with pragma
	No_Body.
	* libgnat/s-atacco.adb: Adjust comment about pragma No_Body.

8 files changed, 75 insertions, 137 deletions

diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 70e779d..c974a9e 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -9560,6 +9560,12 @@ package body Exp_Ch4 is
       Typ   : constant Entity_Id  := Etype (N);
       DDC   : constant Boolean    := Do_Division_Check (N);
 
+      Is_Stoele_Mod : constant Boolean :=
+        Is_RTE (First_Subtype (Typ), RE_Storage_Offset)
+          and then Nkind (Left_Opnd (N)) = N_Unchecked_Type_Conversion
+          and then Is_RTE (Etype (Expression (Left_Opnd (N))), RE_Address);
+      --  True if this is the special mod operator of System.Storage_Elements
+
       Left  : Node_Id;
       Right : Node_Id;
 
@@ -9593,7 +9599,10 @@ package body Exp_Ch4 is
          end if;
       end if;
 
-      if Is_Integer_Type (Typ) then
+      --  For the special mod operator of System.Storage_Elements, the checks
+      --  are subsumed into the handling of the negative case below.
+
+      if Is_Integer_Type (Typ) and then not Is_Stoele_Mod then
          Apply_Divide_Checks (N);
 
          --  All done if we don't have a MOD any more, which can happen as a
@@ -9663,6 +9672,23 @@ package body Exp_Ch4 is
             return;
          end if;
 
+         --  The negative case makes no sense since it is a case of a mod where
+         --  the left argument is unsigned and the right argument is signed. In
+         --  accordance with the (spirit of the) permission of RM 13.7.1(16),
+         --  we raise CE, and also include the zero case here. Yes, the RM says
+         --  PE, but this really is so obviously more like a constraint error.
+
+         if Is_Stoele_Mod and then (not ROK or else Rlo <= 0) then
+            Insert_Action (N,
+              Make_Raise_Constraint_Error (Loc,
+                Condition =>
+                  Make_Op_Le (Loc,
+                    Left_Opnd  => Duplicate_Subexpr_No_Checks (Right),
+                    Right_Opnd => Make_Integer_Literal (Loc, 0)),
+                Reason => CE_Overflow_Check_Failed));
+            return;
+         end if;
+
          --  If we still have a mod operator and we are in Modify_Tree_For_C
          --  mode, and we have a signed integer type, then here is where we do
          --  the rewrite in terms of Rem. Note this rewrite bypasses the need
diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb
index a1e5588..2eee892 100644
--- a/gcc/ada/exp_intr.adb
+++ b/gcc/ada/exp_intr.adb
@@ -102,6 +102,12 @@ package body Exp_Intr is
    --  N_Free_Statement and appropriate context.
 
    procedure Expand_To_Address (N : Node_Id);
+   --  Expand a call to corresponding function from System.Storage_Elements or
+   --  declared in an instance of System.Address_To_Access_Conversions.
+
+   procedure Expand_To_Integer (N : Node_Id);
+   --  Expand a call to corresponding function from System.Storage_Elements
+
    procedure Expand_To_Pointer (N : Node_Id);
    --  Expand a call to corresponding function, declared in an instance of
    --  System.Address_To_Access_Conversions.
@@ -708,6 +714,9 @@ package body Exp_Intr is
       elsif Nam = Name_To_Address then
          Expand_To_Address (N);
 
+      elsif Nam = Name_To_Integer then
+         Expand_To_Integer (N);
+
       elsif Nam = Name_To_Pointer then
          Expand_To_Pointer (N);
 
@@ -1356,6 +1365,12 @@ package body Exp_Intr is
       Obj : Node_Id;
 
    begin
+      if Is_Modular_Integer_Type (Etype (Arg)) then
+         Rewrite (N, Unchecked_Convert_To (Etype (N), Arg));
+         Analyze (N);
+         return;
+      end if;
+
       Remove_Side_Effects (Arg);
 
       Obj := Make_Explicit_Dereference (Loc, Relocate_Node (Arg));
@@ -1375,6 +1390,18 @@ package body Exp_Intr is
    end Expand_To_Address;
 
    -----------------------
+   -- Expand_To_Integer --
+   -----------------------
+
+   procedure Expand_To_Integer (N : Node_Id) is
+      Arg : constant Node_Id := First_Actual (N);
+
+   begin
+      Rewrite (N, Unchecked_Convert_To (Etype (N), Arg));
+      Analyze (N);
+   end Expand_To_Integer;
+
+   -----------------------
    -- Expand_To_Pointer --
    -----------------------
 
diff --git a/gcc/ada/libgnat/s-atacco.adb b/gcc/ada/libgnat/s-atacco.adb
index a98b25c..8c10681 100644
--- a/gcc/ada/libgnat/s-atacco.adb
+++ b/gcc/ada/libgnat/s-atacco.adb
@@ -29,8 +29,8 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
---  This package does not require a body, since it is a package renaming. We
---  provide a dummy file containing a No_Body pragma so that previous versions
---  of the body (which did exist) will not interfere.
+--  This package does not require a body. We provide a dummy file containing a
+--  No_Body pragma so that previous versions of the body (which did exist) will
+--  not interfere.
 
 pragma No_Body;
diff --git a/gcc/ada/libgnat/s-stoele.adb b/gcc/ada/libgnat/s-stoele.adb
index e029f51..dfd1ba3 100644
--- a/gcc/ada/libgnat/s-stoele.adb
+++ b/gcc/ada/libgnat/s-stoele.adb
@@ -29,101 +29,8 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
-with Ada.Unchecked_Conversion;
+--  This package does not require a body. We provide a dummy file containing a
+--  No_Body pragma so that previous versions of the body (which did exist) will
+--  not interfere.
 
-package body System.Storage_Elements is
-
-   pragma Suppress (All_Checks);
-
-   --  Conversion to/from address
-
-   --  Note qualification below of To_Address to avoid ambiguities systems
-   --  where Address is a visible integer type.
-
-   function To_Address is
-     new Ada.Unchecked_Conversion (Storage_Offset, Address);
-   function To_Offset  is
-     new Ada.Unchecked_Conversion (Address, Storage_Offset);
-
-   --  Conversion to/from integers
-
-   --  These functions must be place first because they are inlined_always
-   --  and are used and inlined in other subprograms defined in this unit.
-
-   ----------------
-   -- To_Address --
-   ----------------
-
-   function To_Address (Value : Integer_Address) return Address is
-   begin
-      return Address (Value);
-   end To_Address;
-
-   ----------------
-   -- To_Integer --
-   ----------------
-
-   function To_Integer (Value : Address) return Integer_Address is
-   begin
-      return Integer_Address (Value);
-   end To_Integer;
-
-   --  Address arithmetic
-
-   ---------
-   -- "+" --
-   ---------
-
-   function "+" (Left : Address; Right : Storage_Offset) return Address is
-   begin
-      return Storage_Elements.To_Address
-        (To_Integer (Left) + To_Integer (To_Address (Right)));
-   end "+";
-
-   function "+" (Left : Storage_Offset; Right : Address) return Address is
-   begin
-      return Storage_Elements.To_Address
-        (To_Integer (To_Address (Left)) + To_Integer (Right));
-   end "+";
-
-   ---------
-   -- "-" --
-   ---------
-
-   function "-" (Left : Address; Right : Storage_Offset) return Address is
-   begin
-      return Storage_Elements.To_Address
-        (To_Integer (Left) - To_Integer (To_Address (Right)));
-   end "-";
-
-   function "-" (Left, Right : Address) return Storage_Offset is
-   begin
-      return To_Offset (Storage_Elements.To_Address
-                         (To_Integer (Left) - To_Integer (Right)));
-   end "-";
-
-   -----------
-   -- "mod" --
-   -----------
-
-   function "mod"
-     (Left  : Address;
-      Right : Storage_Offset) return Storage_Offset
-   is
-   begin
-      if Right > 0 then
-         return Storage_Offset
-           (To_Integer (Left) mod Integer_Address (Right));
-
-         --  The negative case makes no sense since it is a case of a mod where
-         --  the left argument is unsigned and the right argument is signed. In
-         --  accordance with the (spirit of the) permission of RM 13.7.1(16),
-         --  we raise CE, and also include the zero case here. Yes, the RM says
-         --  PE, but this really is so obviously more like a constraint error.
-
-      else
-         raise Constraint_Error;
-      end if;
-   end "mod";
-
-end System.Storage_Elements;
+pragma No_Body;
diff --git a/gcc/ada/libgnat/s-stoele.ads b/gcc/ada/libgnat/s-stoele.ads
index 9fd31e7..99a195a 100644
--- a/gcc/ada/libgnat/s-stoele.ads
+++ b/gcc/ada/libgnat/s-stoele.ads
@@ -45,12 +45,6 @@ package System.Storage_Elements is
 
    pragma Annotate (GNATprove, Always_Return, Storage_Elements);
 
-   --  We also add the pragma Pure_Function to the operations in this package,
-   --  because otherwise functions with parameters derived from Address are
-   --  treated as non-pure by the back-end (see exp_ch6.adb). This is because
-   --  in many cases such a parameter is used to hide read/out access to
-   --  objects, and it would be unsafe to treat such functions as pure.
-
    type Storage_Offset is range
      -(2 ** (Integer'(Standard'Address_Size) - 1)) ..
      +(2 ** (Integer'(Standard'Address_Size) - 1)) - Long_Long_Integer'(1);
@@ -73,44 +67,26 @@ package System.Storage_Elements is
    --  Address arithmetic
 
    function "+" (Left : Address; Right : Storage_Offset) return Address;
-   pragma Convention (Intrinsic, "+");
-   pragma Inline_Always ("+");
-   pragma Pure_Function ("+");
-
    function "+" (Left : Storage_Offset; Right : Address) return Address;
-   pragma Convention (Intrinsic, "+");
-   pragma Inline_Always ("+");
-   pragma Pure_Function ("+");
+   pragma Import (Intrinsic, "+");
 
    function "-" (Left : Address; Right : Storage_Offset) return Address;
-   pragma Convention (Intrinsic, "-");
-   pragma Inline_Always ("-");
-   pragma Pure_Function ("-");
-
    function "-" (Left, Right : Address) return Storage_Offset;
-   pragma Convention (Intrinsic, "-");
-   pragma Inline_Always ("-");
-   pragma Pure_Function ("-");
+   pragma Import (Intrinsic, "-");
 
    function "mod"
      (Left  : Address;
-      Right : Storage_Offset) return  Storage_Offset;
-   pragma Convention (Intrinsic, "mod");
-   pragma Inline_Always ("mod");
-   pragma Pure_Function ("mod");
+      Right : Storage_Offset) return Storage_Offset;
+   pragma Import (Intrinsic, "mod");
 
    --  Conversion to/from integers
 
    type Integer_Address is mod Memory_Size;
 
    function To_Address (Value : Integer_Address) return Address;
-   pragma Convention (Intrinsic, To_Address);
-   pragma Inline_Always (To_Address);
-   pragma Pure_Function (To_Address);
+   pragma Import (Intrinsic, To_Address);
 
    function To_Integer (Value : Address) return Integer_Address;
-   pragma Convention (Intrinsic, To_Integer);
-   pragma Inline_Always (To_Integer);
-   pragma Pure_Function (To_Integer);
+   pragma Import (Intrinsic, To_Integer);
 
 end System.Storage_Elements;
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index bace2cf..50ccb39 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -16206,6 +16206,7 @@ package body Sem_Ch3 is
 
       if No (Actual_Subp) then
          if Is_Intrinsic_Subprogram (Parent_Subp) then
+            Set_Convention (New_Subp, Convention_Intrinsic);
             Set_Is_Intrinsic_Subprogram (New_Subp);
 
             if Present (Alias (Parent_Subp))
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 365c750..a99bed0 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -6037,11 +6037,11 @@ package body Sem_Res is
    --  Start of processing for Resolve_Arithmetic_Op
 
    begin
-      if Comes_From_Source (N)
-        and then Ekind (Entity (N)) = E_Function
+      if Ekind (Entity (N)) = E_Function
         and then Is_Imported (Entity (N))
         and then Is_Intrinsic_Subprogram (Entity (N))
       then
+         Generate_Reference (Entity (N), N);
          Resolve_Intrinsic_Operator (N, Typ);
          return;
 
@@ -9710,7 +9710,7 @@ package body Sem_Res is
    --------------------------------
 
    procedure Resolve_Intrinsic_Operator  (N : Node_Id; Typ : Entity_Id) is
-      Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ));
+      Btyp : constant Entity_Id := Implementation_Base_Type (Typ);
       Op   : Entity_Id;
       Arg1 : Node_Id;
       Arg2 : Node_Id;
@@ -10641,11 +10641,11 @@ package body Sem_Res is
          end if;
       end if;
 
-      if Comes_From_Source (N)
-        and then Ekind (Entity (N)) = E_Function
+      if Ekind (Entity (N)) = E_Function
         and then Is_Imported (Entity (N))
         and then Is_Intrinsic_Subprogram (Entity (N))
       then
+         Generate_Reference (Entity (N), N);
          Resolve_Intrinsic_Operator (N, Typ);
          return;
       end if;
diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
index afe7508..cf2efbb 100644
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -1337,9 +1337,10 @@ package Snames is
    Name_Shift_Right                      : constant Name_Id := N + $;
    Name_Shift_Right_Arithmetic           : constant Name_Id := N + $;
    Name_Source_Location                  : constant Name_Id := N + $;
+   Name_To_Integer                       : constant Name_Id := N + $;
+   Name_To_Pointer                       : constant Name_Id := N + $;
    Name_Unchecked_Conversion             : constant Name_Id := N + $;
    Name_Unchecked_Deallocation           : constant Name_Id := N + $;
-   Name_To_Pointer                       : constant Name_Id := N + $;
    Last_Intrinsic_Name                   : constant Name_Id := N + $;
 
    --  Names used in processing intrinsic calls