[Ada] Crash on expression function and discriminant-dependent component

Message ID 20171215113529.GA70032@adacore.com
State New
Headers show
Series
  • [Ada] Crash on expression function and discriminant-dependent component
Related show

Commit Message

Pierre-Marie de Rodat Dec. 15, 2017, 11:35 a.m.
This patch fixes a crash on an expression function that is a completion, when
the return expression includes a reference to a discriminant-dependent
component. An expression function that is a completion freezes all types
referenced in the expression, but some itypes are excluded because they are
frozen elsewhere (in the case pf discriminant-dependent component, when the
type itself is frozen).

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

2017-12-15  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch6.adb (Freeze_Expr_Types): Do not emit a freeze node for
	an itype that is the type of a discriminant-dependent component.

	Fixes QC04-017.

gcc/testsuite/

2017-12-15  Ed Schonberg  <schonberg@adacore.com>

	* gnat.dg/expr_func2.ads, gnat.dg/expr_func2.adb: New testcase.

Patch

Index: sem_ch6.adb
===================================================================
--- sem_ch6.adb	(revision 255683)
+++ sem_ch6.adb	(working copy)
@@ -366,10 +366,13 @@ 
 
             procedure Check_And_Freeze_Type (Typ : Entity_Id) is
             begin
-               --  Skip Itypes created by the preanalysis
+               --  Skip Itypes created by the preanalysis, and itypes
+               --  whose scope is another type (i.e. component subtypes
+               --  that depend on a discriminant),
 
                if Is_Itype (Typ)
-                 and then Scope_Within_Or_Same (Scope (Typ), Def_Id)
+                 and then (Scope_Within_Or_Same (Scope (Typ), Def_Id)
+                   or else Is_Type (Scope (Typ)))
                then
                   return;
                end if;
Index: ../testsuite/gnat.dg/expr_func2.ads
===================================================================
--- ../testsuite/gnat.dg/expr_func2.ads	(revision 0)
+++ ../testsuite/gnat.dg/expr_func2.ads	(revision 0)
@@ -0,0 +1,22 @@ 
+package Expr_Func2 is
+
+   type T_Index is range 1 .. 255;
+
+   type T_Table is array (T_Index range <>) of Boolean;
+
+   type T_Variable_Table (N : T_Index := T_Index'First) is record
+      Table : T_Table (1 .. N);
+   end record;
+
+   type T_A_Variable_Table is access T_Variable_Table;
+
+   function Element (A_Variable_Table : T_A_Variable_Table) return Boolean;
+
+private
+
+   function Element (A_Variable_Table : T_A_Variable_Table) return Boolean is
+     (A_Variable_Table.all.Table (1));
+
+   procedure Foo;
+
+end Expr_Func2;
Index: ../testsuite/gnat.dg/expr_func2.adb
===================================================================
--- ../testsuite/gnat.dg/expr_func2.adb	(revision 0)
+++ ../testsuite/gnat.dg/expr_func2.adb	(revision 0)
@@ -0,0 +1,5 @@ 
+--  { dg-do compile }
+
+package body Expr_Func2 is
+   procedure Foo is null;
+end Expr_Func2;