Patchwork [Ada] Work on inherited predicates (interim step)

login
register
mail settings
Submitter Arnaud Charlet
Date Oct. 22, 2010, 8:52 a.m.
Message ID <20101022085217.GA9907@adacore.com>
Download mbox | patch
Permalink /patch/68812/
State New
Headers show

Comments

Arnaud Charlet - Oct. 22, 2010, 8:52 a.m.
This patch includes some fixes for handling of inherited predicates
but this is not quite working fully yet, so a test is not needed yet.

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

2010-10-22  Robert Dewar  <dewar@adacore.com>

	* einfo.ads, einfo.adb (Has_Predicates): Flag is now on all entities
	(simplifies code).
	* exp_ch13.adb (Build_Predicate_Function): Output info msgs for
	inheritance.
	* sem_ch13.adb (Analyze_Aspect_Specifications): Make sure we have a
	freeze node for entities for which a predicate is specified.
	(Analyze_Aspect_Specifications): Avoid duplicate calls
	* sem_ch3.adb (Analyze_Full_Type_Declaration): Remove attempt to avoid
	duplicate calls to Analye_Aspect_Specifications.

Patch

Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb	(revision 165803)
+++ sem_ch3.adb	(working copy)
@@ -2403,9 +2403,7 @@  package body Sem_Ch3 is
       Set_Optimize_Alignment_Flags (Def_Id);
       Check_Eliminated (Def_Id);
 
-      if Nkind (N) = N_Full_Type_Declaration then
-         Analyze_Aspect_Specifications (N, Def_Id, Aspect_Specifications (N));
-      end if;
+      Analyze_Aspect_Specifications (N, Def_Id, Aspect_Specifications (N));
    end Analyze_Full_Type_Declaration;
 
    ----------------------------------
@@ -4215,8 +4213,8 @@  package body Sem_Ch3 is
       Set_Optimize_Alignment_Flags (Id);
       Check_Eliminated (Id);
 
-      <<Leave>>
-         Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N));
+   <<Leave>>
+      Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N));
    end Analyze_Subtype_Declaration;
 
    --------------------------------
Index: einfo.adb
===================================================================
--- einfo.adb	(revision 165803)
+++ einfo.adb	(working copy)
@@ -1411,7 +1411,6 @@  package body Einfo is
 
    function Has_Predicates (Id : E) return B is
    begin
-      pragma Assert (Is_Type (Id) or else Is_Subprogram (Id));
       return Flag250 (Id);
    end Has_Predicates;
 
@@ -3863,9 +3862,6 @@  package body Einfo is
 
    procedure Set_Has_Predicates (Id : E; V : B := True) is
    begin
-      pragma Assert (Is_Type (Id)
-        or else Ekind (Id) = E_Function
-        or else Ekind (Id) = E_Void);
       Set_Flag250 (Id, V);
    end Set_Has_Predicates;
 
Index: einfo.ads
===================================================================
--- einfo.ads	(revision 165803)
+++ einfo.ads	(working copy)
@@ -1674,11 +1674,11 @@  package Einfo is
 --       such an object and no warning is generated.
 
 --    Has_Predicates (Flag250)
---       Present in type and subtype entities and in subprogram entities. Set
---       if a pragma Predicate or Predicate aspect applies to the type, or if
---       it inherits a Predicate aspect from its parent or progenitor types.
---       Also set in the predicate function entity, to distinguish it among
---       entries in the Subprograms_For_Type.
+--       Present in all entities. Set in type and subtype entities if a pragma
+--       Predicate or Predicate aspect applies to the type, or if it inherits a
+--       Predicate aspect from its parent or progenitor types. Also set in the
+--       predicate function entity, to distinguish it among entries in the
+--       Subprograms_For_Type.
 
 --    Has_Primitive_Operations (Flag120) [base type only]
 --       Present in all type entities. Set if at least one primitive operation
@@ -4666,6 +4666,7 @@  package Einfo is
    --    Has_Pragma_Thread_Local_Storage     (Flag169)
    --    Has_Pragma_Unmodified               (Flag233)
    --    Has_Pragma_Unreferenced             (Flag180)
+   --    Has_Predicates                      (Flag250)
    --    Has_Private_Declaration             (Flag155)
    --    Has_Qualified_Name                  (Flag161)
    --    Has_Stream_Size_Clause              (Flag184)
@@ -4778,7 +4779,6 @@  package Einfo is
    --    Has_Object_Size_Clause              (Flag172)
    --    Has_Pragma_Preelab_Init             (Flag221)
    --    Has_Pragma_Unreferenced_Objects     (Flag212)
-   --    Has_Predicates                      (Flag250)
    --    Has_Primitive_Operations            (Flag120)  (base type only)
    --    Has_Size_Clause                     (Flag29)
    --    Has_Specified_Layout                (Flag100)  (base type only)
@@ -5138,7 +5138,6 @@  package Einfo is
    --    Has_Missing_Return                  (Flag142)
    --    Has_Nested_Block_With_Handler       (Flag101)
    --    Has_Postconditions                  (Flag240)
-   --    Has_Predicates                      (Flag250)
    --    Has_Recursive_Call                  (Flag143)
    --    Has_Subprogram_Descriptor           (Flag93)
    --    Is_Abstract_Subprogram              (Flag19)   (non-generic case only)
@@ -5271,7 +5270,6 @@  package Einfo is
    --    Subprograms_For_Type                (Node29)
    --    Has_Invariants                      (Flag232)
    --    Has_Postconditions                  (Flag240)
-   --    Has_Predicates                      (Flag250)
    --    Is_Machine_Code_Subprogram          (Flag137)
    --    Is_Pure                             (Flag44)
    --    Is_Intrinsic_Subprogram             (Flag64)
@@ -5403,7 +5401,6 @@  package Einfo is
    --    Has_Master_Entity                   (Flag21)
    --    Has_Nested_Block_With_Handler       (Flag101)
    --    Has_Postconditions                  (Flag240)
-   --    Has_Predicates                      (Flag250)
    --    Has_Subprogram_Descriptor           (Flag93)
    --    Is_Abstract_Subprogram              (Flag19)   (non-generic case only)
    --    Is_Asynchronous                     (Flag81)
Index: exp_ch13.adb
===================================================================
--- exp_ch13.adb	(revision 165803)
+++ exp_ch13.adb	(working copy)
@@ -27,6 +27,7 @@  with Atree;    use Atree;
 with Checks;   use Checks;
 with Einfo;    use Einfo;
 with Elists;   use Elists;
+with Errout;   use Errout;
 with Exp_Ch3;  use Exp_Ch3;
 with Exp_Ch6;  use Exp_Ch6;
 with Exp_Imgv; use Exp_Imgv;
@@ -126,12 +127,17 @@  package body Exp_Ch13 is
 
       begin
          if Present (T) and then Present (Predicate_Function (T)) then
+
+            --  Build the call to the predicate function of T
+
             Exp :=
               Make_Predicate_Call
                 (T,
                  Convert_To (T,
                    Make_Identifier (Loc, Chars => Object_Name)));
 
+            --  Add call to evolving expression, using AND THEN if needed
+
             if No (Expr) then
                Expr := Exp;
             else
@@ -140,6 +146,14 @@  package body Exp_Ch13 is
                    Left_Opnd  => Relocate_Node (Expr),
                    Right_Opnd => Exp);
             end if;
+
+            --  Output info message on inheritance if required
+
+            if Opt.List_Inherited_Aspects then
+               Error_Msg_Sloc := Sloc (Predicate_Function (T));
+               Error_Msg_Node_2 := T;
+               Error_Msg_N ("?info: & inherits predicate from & at #", Typ);
+            end if;
          end if;
       end Add_Call;
 
@@ -200,24 +214,27 @@  package body Exp_Ch13 is
                Arg1 := Get_Pragma_Arg (Arg1);
                Arg2 := Get_Pragma_Arg (Arg2);
 
-               --  We need to replace any occurrences of the name of the type
-               --  with references to the object. We do this by first doing a
-               --  preanalysis, to identify all the entities, then we traverse
-               --  looking for the type entity, doing the needed substitution.
-               --  The preanalysis is done with the special OK_To_Reference
-               --  flag set on the type, so that if we get an occurrence of
-               --  this type, it will be recognized as legitimate.
-
-               Set_OK_To_Reference (Typ, True);
-               Preanalyze_Spec_Expression (Arg2, Standard_Boolean);
-               Set_OK_To_Reference (Typ, False);
-               Replace_Type (Arg2);
-
                --  See if this predicate pragma is for the current type
 
                if Entity (Arg1) = Typ then
 
-                  --  We have a match, add the expression
+                  --  We have a match, this entry is for our subtype
+
+                  --  First We need to replace any occurrences of the name of
+                  --  the type with references to the object. We do this by
+                  --  first doing a preanalysis, to identify all the entities,
+                  --  then we traverse looking for the type entity, doing the
+                  --  needed substitution. The preanalysis is done with the
+                  --  special OK_To_Reference flag set on the type, so that if
+                  --  we get an occurrence of this type, it will be recognized
+                  --  as legitimate.
+
+                  Set_OK_To_Reference (Typ, True);
+                  Preanalyze_Spec_Expression (Arg2, Standard_Boolean);
+                  Set_OK_To_Reference (Typ, False);
+                  Replace_Type (Arg2);
+
+                  --  OK, replacement complete, now we can add the expression
 
                   if No (Expr) then
                      Expr := Relocate_Node (Arg2);
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb	(revision 165803)
+++ sem_ch13.adb	(working copy)
@@ -658,10 +658,21 @@  package body Sem_Ch13 is
       --  Set True if delay is required
 
    begin
+      --  Return if no aspects
+
       if L = No_List then
          return;
       end if;
 
+      --  Return if already analyzed (avoids duplicate calls in some cases
+      --  where type declarations get rewritten and proessed twice).
+
+      if Analyzed (N) then
+         return;
+      end if;
+
+      --  Loop through apsects
+
       Aspect := First (L);
       while Present (Aspect) loop
          declare
@@ -1068,6 +1079,12 @@  package body Sem_Ch13 is
 
                   Set_From_Aspect_Specification (Aitem, True);
 
+                  --  Make sure we have a freeze node (it might otherwise be
+                  --  missing in cases like subtype X is Y, and we would not
+                  --  have a place to build the predicate function).
+
+                  Ensure_Freeze_Node (E);
+
                   --  For Predicate case, insert immediately after the entity
                   --  declaration. We do not have to worry about delay issues
                   --  since the pragma processing takes care of this.