[Ada] Crash on build-in-place call with address specification for target

The presence of an address clause complicates the build-in-place expansion
because the indicated address must be processed before the indirect call is
generated, including the definition of a local pointer to the object.

The address clause may come from an aspect specification or from an explicit
attribute specification appearing after the object declaration. These two
cases require different processing.

2018-01-11  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* exp_ch6.adb (Make_Build_In_Place_Call_In_Object_Declaration): Handle
	properly object declarations with initializations that are
	build-in-place function calls, when there is an address specification,
	either as an aspect specification or an explicit attribute
	specification clause, for the initialized object.
	* freeze.adb (Check_Address_Clause): Do not remove side-effects from
	initial expressions in the case of a build-in-place call.

gcc/testsuite/

	* gnat.dg/bip_overlay.adb, gnat.dg/bip_overlay.ads: New testcase.

From-SVN: r256523

gcc/ada/ChangeLog

+2018-01-11  Ed Schonberg  <schonberg@adacore.com>
+
+	* exp_ch6.adb (Make_Build_In_Place_Call_In_Object_Declaration): Handle
+	properly object declarations with initializations that are
+	build-in-place function calls, when there is an address specification,
+	either as an aspect specification or an explicit attribute
+	specification clause, for the initialized object.
+	* freeze.adb (Check_Address_Clause): Do not remove side-effects from
+	initial expressions in the case of a build-in-place call.
+
 2018-01-11  Piotr Trojanek  <trojanek@adacore.com>
 
 	* sem_eval.adb (Is_Null_Range): Retrieve the full view when called on a

gcc/ada/exp_ch6.adb

@@ -24,6 +24,7 @@
 ------------------------------------------------------------------------------
 
 with Atree;     use Atree;
+with Aspects;   use Aspects;
 with Checks;    use Checks;
 with Contracts; use Contracts;
 with Debug;     use Debug;
@@ -8418,7 +8419,66 @@ package body Exp_Ch6 is
       --  freezing.
 
       if Definite and then not Is_Return_Object (Obj_Def_Id) then
+
+         --  The presence of an address clause complicates the build-in-place
+         --  expansion because the indicated address must be processed before
+         --  the indirect call is generated (including the definition of a
+         --  local pointer to the object).  The address clause may come from
+         --  an aspect specification or from an explicit attribute
+         --  specification appearing after the object declaration. These two
+         --  cases require different processing.
+
+         if Has_Aspect (Obj_Def_Id, Aspect_Address) then
+
+            --  Skip non-delayed pragmas that correspond to other aspects, if
+            --  any, to find proper insertion point for freeze node of object.
+
+            declare
+               D : Node_Id := Obj_Decl;
+               N : Node_Id := Next (D);
+
+            begin
+               while Present (N)
+                 and then Nkind_In (N, N_Pragma, N_Attribute_Reference)
+               loop
+                  Analyze (N);
+                  D := N;
+                  Next (N);
+               end loop;
+
+               Insert_After (D, Ptr_Typ_Decl);
+
+               --  Freeze object before pointer declaration, to ensure that
+               --  generated attribute for address is inserted at the proper
+               --  place.
+
+               Freeze_Before (Ptr_Typ_Decl, Obj_Def_Id);
+            end;
+
+            Analyze (Ptr_Typ_Decl);
+
+         elsif Present (Following_Address_Clause (Obj_Decl)) then
+
+            --  Locate explicit address clause, which may also follow pragmas
+            --  generated by other aspect specifications.
+
+            declare
+               Addr : constant Node_Id := Following_Address_Clause (Obj_Decl);
+               D    : Node_Id := Next (Obj_Decl);
+
+            begin
+               while Present (D) loop
+                  Analyze (D);
+                  exit when D = Addr;
+                  Next (D);
+               end loop;
+
+               Insert_After_And_Analyze (Addr, Ptr_Typ_Decl);
+            end;
+
+         else
             Insert_After_And_Analyze (Obj_Decl, Ptr_Typ_Decl);
+         end if;
       else
          Insert_Action (Obj_Decl, Ptr_Typ_Decl);
       end if;

gcc/ada/freeze.adb

@@ -711,11 +711,16 @@ package body Freeze is
             end;
          end if;
 
-         if Present (Init) then
+         --  Remove side effects from initial expression, except in the case
+         --  of a build-in-place call, which has its own later expansion.
 
-            --  Capture initialization value at point of declaration,
-            --  and make explicit assignment legal, because object may
-            --  be a constant.
+         if Present (Init)
+           and then (Nkind (Init) /= N_Function_Call
+             or else not Is_Expanded_Build_In_Place_Call (Init))
+         then
+
+            --  Capture initialization value at point of declaration, and make
+            --  explicit assignment legal, because object may be a constant.
 
             Remove_Side_Effects (Init);
             Lhs := New_Occurrence_Of (E, Sloc (Decl));

gcc/testsuite/ChangeLog

+2018-01-11  Ed Schonberg  <schonberg@adacore.com>
+
+	* gnat.dg/bip_overlay.adb, gnat.dg/bip_overlay.ads: New testcase.
+
 2018-01-11  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* gnat.dg/protected_func.adb, gnat.dg/protected_func.ads: New testcase.

gcc/testsuite/gnat.dg/bip_overlay.adb

+--  { dg-do compile }
+
+with System;
+
+package body BIP_Overlay
+with
+   SPARK_Mode
+is
+   function Init return X
+   is
+   begin
+      return Result : X do
+         Result.E := 0;
+      end return;
+   end Init;
+
+   I : X := Init
+   with
+      Volatile,
+      Async_Readers,
+      Address => System'To_Address (16#1234_5678#);
+
+end BIP_Overlay;

gcc/testsuite/gnat.dg/bip_overlay.ads

+package BIP_Overlay
+ with SPARK_Mode
+is
+   type X (<>) is limited private;
+
+   pragma Warnings (gnatprove, Off,
+     "volatile function ""Init"" has no volatile effects",
+      reason => "Init is a pure function but returns a volatile type.");
+   function Init return X
+   with
+      Volatile_Function;
+
+private
+   type A is limited record
+      E : Integer;
+   end record
+      with
+      Volatile;
+      -- and Async_Readers when implemented;
+
+   type X is limited new A;
+end BIP_Overlay;