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.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-05-31 Ed Schonberg <schonb...@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.--- gcc/ada/checks.adb
+++ 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
--- /dev/null
new file mode 100644
+++ 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;
--- /dev/null
new file mode 100644
+++ 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;
--- /dev/null
new file mode 100644
+++ 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;
--- /dev/null
new file mode 100644
+++ 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;
--- /dev/null
new file mode 100644
+++ 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;
