aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEd Schonberg <schonberg@adacore.com>2018-01-11 08:53:15 +0000
committerPierre-Marie de Rodat <pmderodat@gcc.gnu.org>2018-01-11 08:53:15 +0000
commit52c5090a4f940459ac3e38bcee0fd9f5f86a4eff (patch)
treef6ee50a6149b595f15bbdd02da83116a39fa1a8a
parent2e01b698bd52e3b4af71a5cb03e647d3ac8cf601 (diff)
downloadgcc-52c5090a4f940459ac3e38bcee0fd9f5f86a4eff.zip
gcc-52c5090a4f940459ac3e38bcee0fd9f5f86a4eff.tar.gz
gcc-52c5090a4f940459ac3e38bcee0fd9f5f86a4eff.tar.bz2
[Ada] Crash on expression function as completion, with implicit dereference
An implicit dereference freezes the corresponding designated type. Most implicit dereferences are made explicit during expansion, but this is not the case for a dispatching call where the the controlling parameter and the corresponding controlling argument are access to a tagged type. In that case, to enforce the rule that an expression function that is a completion freezes type references within, we must locate controlling arguments of an access type and freeze explicitly the corresponding designated type. 2018-01-11 Ed Schonberg <schonberg@adacore.com> gcc/ada/ * sem_ch6.adb (Freeze_Expr_Types): If an access value is the controlling argument of a dispatching call. freeze the corresponding designated type. gcc/testsuite/ * gnat.dg/expr_func3.adb, gnat.dg/expr_func3.ads: New testcase. From-SVN: r256507
-rw-r--r--gcc/ada/ChangeLog6
-rw-r--r--gcc/ada/sem_ch6.adb14
-rw-r--r--gcc/testsuite/ChangeLog4
-rw-r--r--gcc/testsuite/gnat.dg/expr_func3.adb7
-rw-r--r--gcc/testsuite/gnat.dg/expr_func3.ads18
5 files changed, 49 insertions, 0 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 9681fbd..fc30104 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,9 @@
+2018-01-11 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Freeze_Expr_Types): If an access value is the
+ controlling argument of a dispatching call. freeze the corresponding
+ designated type.
+
2018-01-11 Ben Brosgol <brosgol@adacore.com>
* doc/Makefile: Add Sphinx option -W to treat warnings as errors.
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index cb5b3e7..1c0495f 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -423,6 +423,20 @@ package body Sem_Ch6 is
Check_And_Freeze_Type (Designated_Type (Etype (Node)));
end if;
+ -- An implicit dereference freezes the designated type. In the
+ -- case of a dispatching call whose controlling argument is an
+ -- access type, the dereference is not made explicit, so we must
+ -- check for such a call and freeze the designated type.
+
+ if Nkind (Node) in N_Has_Etype
+ and then Present (Etype (Node))
+ and then Is_Access_Type (Etype (Node))
+ and then Nkind (Parent (Node)) = N_Function_Call
+ and then Node = Controlling_Argument (Parent (Node))
+ then
+ Check_And_Freeze_Type (Designated_Type (Etype (Node)));
+ end if;
+
-- No point in posting several errors on the same expression
if Serious_Errors_Detected > 0 then
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 66e77cc..0ea0a93 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,5 +1,9 @@
2018-01-11 Ed Schonberg <schonberg@adacore.com>
+ * gnat.dg/expr_func3.adb, gnat.dg/expr_func3.ads: New testcase.
+
+2018-01-11 Ed Schonberg <schonberg@adacore.com>
+
* gnat.dg/fixedpnt2.adb, gnat.dg/fixedpnt2.ads: New testcase.
2018-01-11 Justin Squirek <squirek@adacore.com>
diff --git a/gcc/testsuite/gnat.dg/expr_func3.adb b/gcc/testsuite/gnat.dg/expr_func3.adb
new file mode 100644
index 0000000..3e4d583
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/expr_func3.adb
@@ -0,0 +1,7 @@
+-- { dg-do compile }
+
+package body Expr_Func3 is
+
+ procedure Dummy is null;
+
+end Expr_Func3;
diff --git a/gcc/testsuite/gnat.dg/expr_func3.ads b/gcc/testsuite/gnat.dg/expr_func3.ads
new file mode 100644
index 0000000..45593da
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/expr_func3.ads
@@ -0,0 +1,18 @@
+package Expr_Func3 is
+
+ type Obj_T is abstract tagged null record;
+
+ type T is access all Obj_T'Class;
+
+ function Slave (Obj : access Obj_T) return T is (T(Obj));
+
+ function Optional_Slave (Obj : T) return T;
+
+ procedure Dummy;
+
+private
+
+ function Optional_Slave (Obj : T) return T is
+ (if Obj = null then null else Slave (Obj));
+
+end Expr_Func3;