[Ada] Illegal copy of limited object

This patch fixes a spurious copy of a limited object, when that object
is a discriminated record component of a limited type LT, and the enclosing
record is initialized by means of an aggregate, one of whose components is a
call to a build-in-place function that returns an unconstrained object of
type T.

2018-05-31  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* checks.adb (Apply_Discriminant_Check): Do not apply discriminant
	check to a call to a build-in-place function, given that the return
	object is limited and cannot be copied.

gcc/testsuite/

	* gnat.dg/limited1.adb, gnat.dg/limited1_inner.adb,
	gnat.dg/limited1_inner.ads, gnat.dg/limited1_outer.adb,
	gnat.dg/limited1_outer.ads: New testcase.

From-SVN: r261009

8 files changed, 82 insertions, 0 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 6150102..47bf996 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,9 @@
+2018-05-31  Ed Schonberg  <schonberg@adacore.com>
+
+	* checks.adb (Apply_Discriminant_Check): Do not apply discriminant
+	check to a call to a build-in-place function, given that the return
+	object is limited and cannot be copied.
+
 2018-05-31  Olivier Hainque  <hainque@adacore.com>
 
 	* libgnat/s-atopri.ads: Update comment on __atomic_compare_exchange
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index 584e747..8e061eb 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -1458,6 +1458,19 @@ package body Checks is
          T_Typ := Typ;
       end if;
 
+      --  If the expression is a function call that returns a limited object
+      --  it cannot be copied. It is not clear how to perform the proper
+      --  discriminant check in this case because the discriminant value must
+      --  be retrieved from the constructed object itself.
+
+      if Nkind (N) = N_Function_Call
+        and then Is_Limited_Type (Typ)
+        and then Is_Entity_Name (Name (N))
+        and then Returns_By_Ref (Entity (Name (N)))
+      then
+         return;
+      end if;
+
       --  Only apply checks when generating code and discriminant checks are
       --  not suppressed. In GNATprove mode, we do not apply the checks, but we
       --  still analyze the expression to possibly issue errors on SPARK code
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 82af062..a1921f1 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2018-05-31  Ed Schonberg  <schonberg@adacore.com>
+
+	* gnat.dg/limited1.adb, gnat.dg/limited1_inner.adb,
+	gnat.dg/limited1_inner.ads, gnat.dg/limited1_outer.adb,
+	gnat.dg/limited1_outer.ads: New testcase.
+
 2018-05-31  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* gnat.dg/tampering_check1.adb, gnat.dg/tampering_check1_ivectors.ads,
diff --git a/gcc/testsuite/gnat.dg/limited1.adb b/gcc/testsuite/gnat.dg/limited1.adb
new file mode 100644
index 0000000..0278fe1
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/limited1.adb
@@ -0,0 +1,9 @@
+--  { dg-do run }
+
+with Limited1_Outer; use Limited1_Outer;
+
+procedure Limited1 is
+   X : Outer_Type := Make_Outer;
+begin
+   null;
+end;
diff --git a/gcc/testsuite/gnat.dg/limited1_inner.adb b/gcc/testsuite/gnat.dg/limited1_inner.adb
new file mode 100644
index 0000000..c943b2d
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/limited1_inner.adb
@@ -0,0 +1,15 @@
+package body Limited1_Inner is
+   overriding procedure Finalize (X : in out Limited_Type) is
+   begin
+      if X.Self /= X'Unchecked_Access then
+         raise Program_Error with "Copied!";
+      end if;
+   end;
+
+   function Make_Inner return Inner_Type is
+   begin
+      return Inner : Inner_Type (True) do
+         null;
+      end return;
+   end;
+end;
diff --git a/gcc/testsuite/gnat.dg/limited1_inner.ads b/gcc/testsuite/gnat.dg/limited1_inner.ads
new file mode 100644
index 0000000..a06c903
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/limited1_inner.ads
@@ -0,0 +1,18 @@
+with Ada.Finalization;
+package Limited1_Inner is
+   type Limited_Type is new Ada.Finalization.Limited_Controlled with record
+      Self : access Limited_Type := Limited_Type'Unchecked_Access;
+   end record;
+   overriding procedure Finalize (X : in out Limited_Type);
+
+   type Inner_Type (What : Boolean) is record
+      case What is
+         when False =>
+            null;
+         when True =>
+            L : Limited_Type;
+      end case;
+   end record;
+
+   function Make_Inner return Inner_Type;
+end;
diff --git a/gcc/testsuite/gnat.dg/limited1_outer.adb b/gcc/testsuite/gnat.dg/limited1_outer.adb
new file mode 100644
index 0000000..607cc93
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/limited1_outer.adb
@@ -0,0 +1,6 @@
+package body Limited1_Outer is
+   function Make_Outer return Outer_Type is
+   begin
+      return (What => True, Inner => Make_Inner);
+   end;
+end;
diff --git a/gcc/testsuite/gnat.dg/limited1_outer.ads b/gcc/testsuite/gnat.dg/limited1_outer.ads
new file mode 100644
index 0000000..d787ca8
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/limited1_outer.ads
@@ -0,0 +1,9 @@
+with Limited1_Inner; use Limited1_Inner;
+
+package Limited1_Outer is
+   type Outer_Type (What : Boolean) is record
+      Inner : Inner_Type (What);
+   end record;
+
+   function Make_Outer return Outer_Type;
+end Limited1_Outer;