From 6ae40af30c0d2db1fe3d9610ade37004ee0c1d38 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Thu, 31 May 2018 10:47:03 +0000 Subject: [PATCH] [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 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 --- gcc/ada/ChangeLog | 6 ++++++ gcc/ada/checks.adb | 13 +++++++++++++ gcc/testsuite/ChangeLog | 6 ++++++ gcc/testsuite/gnat.dg/limited1.adb | 9 +++++++++ gcc/testsuite/gnat.dg/limited1_inner.adb | 15 +++++++++++++++ gcc/testsuite/gnat.dg/limited1_inner.ads | 18 ++++++++++++++++++ gcc/testsuite/gnat.dg/limited1_outer.adb | 6 ++++++ gcc/testsuite/gnat.dg/limited1_outer.ads | 9 +++++++++ 8 files changed, 82 insertions(+) create mode 100644 gcc/testsuite/gnat.dg/limited1.adb create mode 100644 gcc/testsuite/gnat.dg/limited1_inner.adb create mode 100644 gcc/testsuite/gnat.dg/limited1_inner.ads create mode 100644 gcc/testsuite/gnat.dg/limited1_outer.adb create mode 100644 gcc/testsuite/gnat.dg/limited1_outer.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6150102dc1a..47bf9969469 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,9 @@ +2018-05-31 Ed Schonberg + + * 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 * libgnat/s-atopri.ads: Update comment on __atomic_compare_exchange diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 584e74734bc..8e061ebfd48 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 82af0622dd7..a1921f1df1f 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2018-05-31 Ed Schonberg + + * 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 * 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 00000000000..0278fe103d2 --- /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 00000000000..c943b2d44b7 --- /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 00000000000..a06c9034f06 --- /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 00000000000..607cc938991 --- /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 00000000000..d787ca8febe --- /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; -- 2.30.2