[Ada] Work on inherited predicates (interim step)
Arnaud Charlet
charlet@adacore.com
Fri Oct 22 09:15:00 GMT 2010
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.
-------------- next part --------------
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.
More information about the Gcc-patches
mailing list