[Ada] Crash on predicate in full view in a generic unit
diff mbox series

Message ID 20190919132819.GA41731@adacore.com
State New
Headers show
Series
  • [Ada] Crash on predicate in full view in a generic unit
Related show

Commit Message

Pierre-Marie de Rodat Sept. 19, 2019, 1:28 p.m. UTC
This patch fixes a compiler abort on a dynamic predicate applied to the
full view of a type in a generic package declaration, when the
expression for the predicate is a conditionql expression that contains
references to components of the full view of the type.

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

2019-09-19  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* sem_ch13.adb (Check_Aspect_At_End_Of_Declarations): Simplify
	handling of expressions in predicates when the context is a
	generic unit.

gcc/testsuite/

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

Patch
diff mbox series

--- gcc/ada/sem_ch13.adb
+++ gcc/ada/sem_ch13.adb
@@ -9374,17 +9374,22 @@  package body Sem_Ch13 is
 
       else
          --  In a generic context freeze nodes are not always generated, so
-         --  analyze the expression now. If the aspect is for a type, this
-         --  makes its potential components accessible.
+         --  analyze the expression now. If the aspect is for a type, we must
+         --  also make its potential components accessible.
 
          if not Analyzed (Freeze_Expr) and then Inside_A_Generic then
             if A_Id = Aspect_Dynamic_Predicate
               or else A_Id = Aspect_Predicate
-              or else A_Id = Aspect_Priority
             then
                Push_Type (Ent);
-               Preanalyze_Spec_Expression (Freeze_Expr, T);
+               Preanalyze_Spec_Expression (Freeze_Expr, Standard_Boolean);
+               Pop_Type (Ent);
+
+            elsif A_Id = Aspect_Priority then
+               Push_Type (Ent);
+               Preanalyze_Spec_Expression (Freeze_Expr, Any_Integer);
                Pop_Type (Ent);
+
             else
                Preanalyze (Freeze_Expr);
             end if;
@@ -9395,12 +9400,23 @@  package body Sem_Ch13 is
 
          Set_Parent (End_Decl_Expr, ASN);
 
-         --  In a generic context the aspect expressions have not been
-         --  preanalyzed, so do it now. There are no conformance checks
-         --  to perform in this case.
+         --  In a generic context the original  aspect expressions have not
+         --  been preanalyzed, so do it now. There are no conformance checks
+         --  to perform in this case. As before, we have to make components
+         --  visible for aspects that may reference them.
 
          if No (T) then
-            Check_Aspect_At_Freeze_Point (ASN);
+            if A_Id = Aspect_Dynamic_Predicate
+              or else A_Id = Aspect_Predicate
+              or else A_Id = Aspect_Priority
+            then
+               Push_Type (Ent);
+               Check_Aspect_At_Freeze_Point (ASN);
+               Pop_Type (Ent);
+
+            else
+               Check_Aspect_At_Freeze_Point (ASN);
+            end if;
             return;
 
          --  The default values attributes may be defined in the private part,

--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/predicate14.adb
@@ -0,0 +1,4 @@ 
+--  { dg-do compile }
+package body Predicate14 is
+    procedure Dummy is null;
+end Predicate14;

--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/predicate14.ads
@@ -0,0 +1,56 @@ 
+generic
+package Predicate14 with
+  SPARK_Mode
+is
+
+   type Field_Type is (F_Initial, F_Payload, F_Final);
+
+   type State_Type is (S_Valid, S_Invalid);
+
+   type Cursor_Type (State : State_Type := S_Invalid) is private;
+
+   type Cursors_Type is array (Field_Type) of Cursor_Type;
+
+   type Context_Type is private;
+
+   type Result_Type (Field : Field_Type := F_Initial) is
+      record
+         case Field is
+            when F_Initial | F_Final =>
+               null;
+            when F_Payload =>
+               Value : Integer;
+         end case;
+      end record;
+
+   function Valid_Context (Context : Context_Type) return Boolean;
+
+private
+
+   function Valid_Type (Result : Result_Type) return Boolean is
+     (Result.Field = F_Initial);
+
+   type Cursor_Type (State : State_Type := S_Invalid) is
+      record
+         case State is
+            when S_Valid =>
+               Value : Result_Type;
+            when S_Invalid =>
+               null;
+         end case;
+      end record
+      with Dynamic_Predicate =>
+          (if State = S_Valid then Valid_Type (Value));
+
+   type Context_Type is
+      record
+         Field : Field_Type := F_Initial;
+         Cursors : Cursors_Type := (others => (State => S_Invalid));
+      end record;
+
+   function Valid_Context (Context : Context_Type) return Boolean is
+     (for all F in Context.Cursors'Range =>
+         (Context.Cursors (F).Value.Field = F));
+
+   procedure Dummy;
+end Predicate14;
\ No newline at end of file