diff options
author | Eric Botcazou <ebotcazou@adacore.com> | 2024-01-09 11:06:23 +0100 |
---|---|---|
committer | Eric Botcazou <ebotcazou@adacore.com> | 2024-01-09 11:06:23 +0100 |
commit | 8f80b9f0904eb98b41913068ce7dc021c2f35ecc (patch) | |
tree | 8c6a32273d3d3af695e122d0b6aeb58d15887993 /gcc/testsuite/gnat.dg | |
parent | 436ce7a3510000e0939094592fc12353e17527f1 (diff) | |
download | gcc-8f80b9f0904eb98b41913068ce7dc021c2f35ecc.zip gcc-8f80b9f0904eb98b41913068ce7dc021c2f35ecc.tar.gz gcc-8f80b9f0904eb98b41913068ce7dc021c2f35ecc.tar.bz2 |
Fix internal error on function call returning extension of limited interface
The problem occurs when this function call is the expression of a return in
a function returning the limited interface; in this peculiar case, there is
a mismatch between the callee, which has BIP formals but is not a BIP call,
and the caller, which is a BIP function, that is spotted by an assertion.
This is fixed by restoring the semantics of Is_Build_In_Place_Function_Call,
which returns again true only for calls to BIP functions, introducing the
Is_Function_Call_With_BIP_Formals predicate, which also returns true for
calls to functions with BIP formals that are not BIP functions, and moving
down the assertion in Expand_Simple_Function_Return.
gcc/ada/
PR ada/112781
* exp_ch6.ads (Is_Build_In_Place_Function): Adjust description.
* exp_ch6.adb (Is_True_Build_In_Place_Function_Call): Delete.
(Is_Function_Call_With_BIP_Formals): New predicate.
(Is_Build_In_Place_Function_Call): Restore original semantics.
(Expand_Call_Helper): Adjust conditions guarding the calls to
Add_Dummy_Build_In_Place_Actuals to above renaming.
(Expand_N_Extended_Return_Statement): Adjust to above renaming.
(Expand_Simple_Function_Return): Likewise. Move the assertion
to after the transformation into an extended return statement.
(Make_Build_In_Place_Call_In_Allocator): Remove unreachable code.
(Make_Build_In_Place_Call_In_Assignment): Likewise.
gcc/testsuite/
* gnat.dg/bip_prim_func2.adb: New test.
* gnat.dg/bip_prim_func2_pkg.ads, gnat.dg/bip_prim_func2_pkg.adb:
New helper package.
Diffstat (limited to 'gcc/testsuite/gnat.dg')
-rw-r--r-- | gcc/testsuite/gnat.dg/bip_prim_func2.adb | 23 | ||||
-rw-r--r-- | gcc/testsuite/gnat.dg/bip_prim_func2_pkg.adb | 23 | ||||
-rw-r--r-- | gcc/testsuite/gnat.dg/bip_prim_func2_pkg.ads | 17 |
3 files changed, 63 insertions, 0 deletions
diff --git a/gcc/testsuite/gnat.dg/bip_prim_func2.adb b/gcc/testsuite/gnat.dg/bip_prim_func2.adb new file mode 100644 index 0000000..e139c89 --- /dev/null +++ b/gcc/testsuite/gnat.dg/bip_prim_func2.adb @@ -0,0 +1,23 @@ +-- { dg-do run } + +with BIP_Prim_Func2_Pkg; + +procedure BIP_Prim_Func2 is + + package B is + type Instance is limited interface; + function Make return Instance is abstract; + end B; + + package C is + type Instance is new B.Instance with null record; + function Make return Instance is (null record); + end C; + + package T is new BIP_Prim_Func2_Pkg (B.Instance, C.Instance, C.Make); + + Thing : B.Instance'Class := T.Make (2); + +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/bip_prim_func2_pkg.adb b/gcc/testsuite/gnat.dg/bip_prim_func2_pkg.adb new file mode 100644 index 0000000..5a4591a --- /dev/null +++ b/gcc/testsuite/gnat.dg/bip_prim_func2_pkg.adb @@ -0,0 +1,23 @@ +with Ada.Containers.Indefinite_Ordered_Maps; + +package body BIP_Prim_Func2_Pkg is + + package Maps is new Ada.Containers.Indefinite_Ordered_Maps + (Key_Type => Integer, + Element_Type => Some_Access); + + Map : Maps.Map; + + function Make (Key : Integer) return First'Class is + begin + return Map(Key).all; + end Make; + + function Make_Delegate return First'Class is + begin + return Make; + end Make_Delegate; + +begin + Map.Insert (2,Thing_Access); +end BIP_Prim_Func2_Pkg; diff --git a/gcc/testsuite/gnat.dg/bip_prim_func2_pkg.ads b/gcc/testsuite/gnat.dg/bip_prim_func2_pkg.ads new file mode 100644 index 0000000..de0ecd7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/bip_prim_func2_pkg.ads @@ -0,0 +1,17 @@ +generic + type First(<>) is abstract tagged limited private; + type Second(<>) is new First with private; + with function Make return Second is <>; +package BIP_Prim_Func2_Pkg is + + function Make (Key : Integer) return First'Class; + +private + + type Some_Access is not null access function return First'Class; + + function Make_Delegate return First'Class; + + Thing_Access : constant Some_Access := Make_Delegate'Access; + +end BIP_Prim_Func2_Pkg; |