This patch implements Ada 2012 AI-0022, which specifies that a raise
expression that is executed in a predicate that is tested during the
execution of a membership test causes the test to fail (or succeed
for NOT IN), rather than raising an exception.
The following, compiled with -gnata:
1. pragma Ada_2012;
2. with Text_IO; use Text_IO;
3. procedure RaiseEXMem is
4. function Is_Gnarly (X : Integer) return Boolean is
5. begin
6. return X > 20;
7. end Is_Gnarly;
8.
9. subtype S is Integer with
10. Dynamic_Predicate => Is_Gnarly (S)
11. or else raise Program_Error;
12.
13. begin
14. if 10 in S then
15. Put_Line ("predicate was true (unexpected)!");
16. else
17. Put_Line ("predicate was false as expected!");
18. end if;
19.
20. if 42 in S then
21. Put_Line ("predicate was true as expected!");
22. else
23. Put_Line ("predicate was false (unexpected)!");
24. end if;
25.
26.
27. exception
28. when others =>
29. Put_Line ("unexpected exception was raised");
30. end RaiseEXMem;
prints out
predicate was false as expected!
predicate was true as expected!
Tested on x86_64-pc-linux-gnu, committed on trunk
2013-04-11 Robert Dewar <de...@adacore.com>
* atree.h: Add declarations for Flag255-Flag289 Fix declaration
of Field30 (was wrong, but no effect, since not yet referenced by
back end) Add declarations for Field31-Field35 Add declarations
for Node31-Node35.
* einfo.ads, einfo.adb (Has_Invariants): No longer applies to
procedures.
(Has_Predicates): No longer applies to functions.
(Is_Predicate_Function): New flag.
(Is_Predicate_Function_M): New flag.
(Is_Invariant_Procedure): New flag.
(Predicate_Function_M): New function.
(Set_Predicate_Function_M): New procedure.
* exp_ch11.adb (Expand_N_Raise_Expression): Take care of special
case of appearing in predicate used for membership test.
* exp_ch3.adb (Insert_Component_Invariant_Checks): Set
Is_Invariant_Procedure flag.
* exp_ch4.adb (Expand_Op_In): Call special predicate function
that takes care of raise_expression nodes in the predicate.
* exp_util.ads, exp_util.adb (Make_Predicate_Call): Add argument Mem for
membership case.
* sem_ch13.adb (Build_Predicate_Functions): New name for
Build_Predicate_Function. Major rewrite to take care of raise
expression in predicate for membership tests.
* sem_res.adb (Resolve_Actuals): Include both predicate functions
in defense against infinite predicate function loops.
* sinfo.ads, sinfo.adb (Convert_To_Return_False): New flag.
Index: exp_util.adb
===================================================================
--- exp_util.adb (revision 197764)
+++ exp_util.adb (working copy)
@@ -5520,18 +5520,36 @@
function Make_Predicate_Call
(Typ : Entity_Id;
- Expr : Node_Id) return Node_Id
+ Expr : Node_Id;
+ Mem : Boolean := False) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Expr);
begin
pragma Assert (Present (Predicate_Function (Typ)));
+ -- Call special membership version if requested and available
+
+ if Mem then
+ declare
+ PFM : constant Entity_Id := Predicate_Function_M (Typ);
+ begin
+ if Present (PFM) then
+ return
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (PFM, Loc),
+ Parameter_Associations => New_List (Relocate_Node (Expr)));
+ end if;
+ end;
+ end if;
+
+ -- Case of calling normal predicate function
+
return
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (Predicate_Function (Typ), Loc),
- Parameter_Associations => New_List (Relocate_Node (Expr)));
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (Predicate_Function (Typ), Loc),
+ Parameter_Associations => New_List (Relocate_Node (Expr)));
end Make_Predicate_Call;
--------------------------
Index: exp_util.ads
===================================================================
--- exp_util.ads (revision 197743)
+++ exp_util.ads (working copy)
@@ -647,9 +647,12 @@
function Make_Predicate_Call
(Typ : Entity_Id;
- Expr : Node_Id) return Node_Id;
+ Expr : Node_Id;
+ Mem : Boolean := False) return Node_Id;
-- Typ is a type with Predicate_Function set. This routine builds a call to
-- this function passing Expr as the argument, and returns it unanalyzed.
+ -- If Mem is set True, this is the special call for the membership case,
+ -- and the function called is the Predicate_Function_M if present.
function Make_Predicate_Check
(Typ : Entity_Id;
Index: sinfo.adb
===================================================================
--- sinfo.adb (revision 197764)
+++ sinfo.adb (working copy)
@@ -602,6 +602,14 @@
return Flag14 (N);
end Conversion_OK;
+ function Convert_To_Return_False
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Raise_Expression);
+ return Flag13 (N);
+ end Convert_To_Return_False;
+
function Corresponding_Aspect
(N : Node_Id) return Node_Id is
begin
@@ -3685,6 +3693,14 @@
Set_Flag14 (N, Val);
end Set_Conversion_OK;
+ procedure Set_Convert_To_Return_False
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Raise_Expression);
+ Set_Flag13 (N, Val);
+ end Set_Convert_To_Return_False;
+
procedure Set_Corresponding_Aspect
(N : Node_Id; Val : Node_Id) is
begin
Index: sinfo.ads
===================================================================
--- sinfo.ads (revision 197764)
+++ sinfo.ads (working copy)
@@ -720,6 +720,12 @@
-- direct conversion of the underlying integer result, with no regard to
-- the small operand.
+ -- Convert_To_Return_False (Flag13-Sem)
+ -- Present in N_Raise_Expression nodes that appear in the body of the
+ -- special predicateM function used to test a predicate in the context
+ -- of a membership test, where raise expression results in returning a
+ -- value of False rather than raising an exception.
+
-- Corresponding_Aspect (Node3-Sem)
-- Present in N_Pragma node. Used to point back to the source aspect from
-- the corresponding pragma. This field is Empty for source pragmas.
@@ -6139,6 +6145,7 @@
-- Sloc points to RAISE
-- Name (Node2) (always present)
-- Expression (Node3) (set to Empty if no expression present)
+ -- Convert_To_Return_False (Flag13-Sem)
-- plus fields for expression
-------------------------------
@@ -8299,6 +8306,9 @@
function Conversion_OK
(N : Node_Id) return Boolean; -- Flag14
+ function Convert_To_Return_False
+ (N : Node_Id) return Boolean; -- Flag13
+
function Corresponding_Aspect
(N : Node_Id) return Node_Id; -- Node3
@@ -9280,6 +9290,9 @@
procedure Set_Conversion_OK
(N : Node_Id; Val : Boolean := True); -- Flag14
+ procedure Set_Convert_To_Return_False
+ (N : Node_Id; Val : Boolean := True); -- Flag13
+
procedure Set_Corresponding_Aspect
(N : Node_Id; Val : Node_Id); -- Node3
@@ -11880,6 +11893,7 @@
pragma Inline (Context_Items);
pragma Inline (Context_Pending);
pragma Inline (Controlling_Argument);
+ pragma Inline (Convert_To_Return_False);
pragma Inline (Conversion_OK);
pragma Inline (Corresponding_Aspect);
pragma Inline (Corresponding_Body);
@@ -12204,6 +12218,7 @@
pragma Inline (Set_Context_Items);
pragma Inline (Set_Context_Pending);
pragma Inline (Set_Controlling_Argument);
+ pragma Inline (Set_Convert_To_Return_False);
pragma Inline (Set_Conversion_OK);
pragma Inline (Set_Corresponding_Aspect);
pragma Inline (Set_Corresponding_Body);
Index: einfo.adb
===================================================================
--- einfo.adb (revision 197743)
+++ einfo.adb (working copy)
@@ -542,10 +542,10 @@
-- Is_Processed_Transient Flag252
-- Has_Anonymous_Master Flag253
-- Is_Implementation_Defined Flag254
+ -- Is_Predicate_Function Flag255
+ -- Is_Predicate_Function_M Flag256
+ -- Is_Invariant_Procedure Flag257
- -- (unused) Flag255
- -- (unused) Flag256
- -- (unused) Flag257
-- (unused) Flag258
-- (unused) Flag259
-- (unused) Flag260
@@ -578,41 +578,9 @@
-- (unused) Flag284
-- (unused) Flag285
-- (unused) Flag286
- -- (unused) Flag287
- -- (unused) Flag288
- -- (unused) Flag289
- -- (unused) Flag290
- -- (unused) Flag291
- -- (unused) Flag292
- -- (unused) Flag293
- -- (unused) Flag294
- -- (unused) Flag295
- -- (unused) Flag296
- -- (unused) Flag297
- -- (unused) Flag298
- -- (unused) Flag299
- -- (unused) Flag300
+ -- Note: Flag287-317 are defined in atree.ads/adb, but not yet in atree.h
- -- (unused) Flag301
- -- (unused) Flag302
- -- (unused) Flag303
- -- (unused) Flag304
- -- (unused) Flag305
- -- (unused) Flag306
- -- (unused) Flag307
- -- (unused) Flag308
- -- (unused) Flag309
- -- (unused) Flag310
-
- -- (unused) Flag311
- -- (unused) Flag312
- -- (unused) Flag313
- -- (unused) Flag314
- -- (unused) Flag315
- -- (unused) Flag316
- -- (unused) Flag317
-
-----------------------
-- Local subprograms --
-----------------------
@@ -1488,9 +1456,7 @@
function Has_Invariants (Id : E) return B is
begin
- pragma Assert (Is_Type (Id)
- or else Ekind (Id) = E_Procedure
- or else Ekind (Id) = E_Generic_Procedure);
+ pragma Assert (Is_Type (Id));
return Flag232 (Id);
end Has_Invariants;
@@ -1614,6 +1580,7 @@
function Has_Predicates (Id : E) return B is
begin
+ pragma Assert (Is_Type (Id));
return Flag250 (Id);
end Has_Predicates;
@@ -2076,6 +2043,12 @@
return Flag64 (Id);
end Is_Intrinsic_Subprogram;
+ function Is_Invariant_Procedure (Id : E) return B is
+ begin
+ pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure);
+ return Flag257 (Id);
+ end Is_Invariant_Procedure;
+
function Is_Itype (Id : E) return B is
begin
return Flag91 (Id);
@@ -2167,6 +2140,18 @@
return Flag9 (Id);
end Is_Potentially_Use_Visible;
+ function Is_Predicate_Function (Id : E) return B is
+ begin
+ pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure);
+ return Flag255 (Id);
+ end Is_Predicate_Function;
+
+ function Is_Predicate_Function_M (Id : E) return B is
+ begin
+ pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure);
+ return Flag256 (Id);
+ end Is_Predicate_Function_M;
+
function Is_Preelaborated (Id : E) return B is
begin
return Flag59 (Id);
@@ -4037,9 +4022,7 @@
procedure Set_Has_Invariants (Id : E; V : B := True) is
begin
- pragma Assert (Is_Type (Id)
- or else Ekind (Id) = E_Procedure
- or else Ekind (Id) = E_Void);
+ pragma Assert (Is_Type (Id));
Set_Flag232 (Id, V);
end Set_Has_Invariants;
@@ -4172,6 +4155,7 @@
procedure Set_Has_Predicates (Id : E; V : B := True) is
begin
+ pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Void);
Set_Flag250 (Id, V);
end Set_Has_Predicates;
@@ -4658,6 +4642,12 @@
Set_Flag64 (Id, V);
end Set_Is_Intrinsic_Subprogram;
+ procedure Set_Is_Invariant_Procedure (Id : E; V : B := True) is
+ begin
+ pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure);
+ Set_Flag257 (Id, V);
+ end Set_Is_Invariant_Procedure;
+
procedure Set_Is_Itype (Id : E; V : B := True) is
begin
Set_Flag91 (Id, V);
@@ -4752,6 +4742,18 @@
Set_Flag9 (Id, V);
end Set_Is_Potentially_Use_Visible;
+ procedure Set_Is_Predicate_Function (Id : E; V : B := True) is
+ begin
+ pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure);
+ Set_Flag255 (Id, V);
+ end Set_Is_Predicate_Function;
+
+ procedure Set_Is_Predicate_Function_M (Id : E; V : B := True) is
+ begin
+ pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure);
+ Set_Flag256 (Id, V);
+ end Set_Is_Predicate_Function_M;
+
procedure Set_Is_Preelaborated (Id : E; V : B := True) is
begin
Set_Flag59 (Id, V);
@@ -6403,7 +6405,7 @@
else
S := Subprograms_For_Type (Id);
while Present (S) loop
- if Has_Invariants (S) then
+ if Is_Invariant_Procedure (S) then
return S;
else
S := Subprograms_For_Type (S);
@@ -7121,7 +7123,7 @@
else
S := Subprograms_For_Type (Id);
while Present (S) loop
- if Has_Predicates (S) then
+ if Is_Predicate_Function (S) then
return S;
else
S := Subprograms_For_Type (S);
@@ -7132,6 +7134,33 @@
end if;
end Predicate_Function;
+ --------------------------
+ -- Predicate_Function_M --
+ --------------------------
+
+ function Predicate_Function_M (Id : E) return E is
+ S : Entity_Id;
+
+ begin
+ pragma Assert (Is_Type (Id));
+
+ if No (Subprograms_For_Type (Id)) then
+ return Empty;
+
+ else
+ S := Subprograms_For_Type (Id);
+ while Present (S) loop
+ if Is_Predicate_Function_M (S) then
+ return S;
+ else
+ S := Subprograms_For_Type (S);
+ end if;
+ end loop;
+
+ return Empty;
+ end if;
+ end Predicate_Function_M;
+
-------------------------
-- Present_In_Rep_Item --
-------------------------
@@ -7365,8 +7394,10 @@
Set_Subprograms_For_Type (Id, V);
Set_Subprograms_For_Type (V, S);
+ -- Check for duplicate entry
+
while Present (S) loop
- if Has_Invariants (S) then
+ if Is_Invariant_Procedure (S) then
raise Program_Error;
else
S := Subprograms_For_Type (S);
@@ -7389,7 +7420,7 @@
Set_Subprograms_For_Type (V, S);
while Present (S) loop
- if Has_Predicates (S) then
+ if Is_Predicate_Function (S) then
raise Program_Error;
else
S := Subprograms_For_Type (S);
@@ -7397,6 +7428,31 @@
end loop;
end Set_Predicate_Function;
+ ------------------------------
+ -- Set_Predicate_Function_M --
+ ------------------------------
+
+ procedure Set_Predicate_Function_M (Id : E; V : E) is
+ S : Entity_Id;
+
+ begin
+ pragma Assert (Is_Type (Id) and then Has_Predicates (Id));
+
+ S := Subprograms_For_Type (Id);
+ Set_Subprograms_For_Type (Id, V);
+ Set_Subprograms_For_Type (V, S);
+
+ -- Check for duplicates
+
+ while Present (S) loop
+ if Is_Predicate_Function_M (S) then
+ raise Program_Error;
+ else
+ S := Subprograms_For_Type (S);
+ end if;
+ end loop;
+ end Set_Predicate_Function_M;
+
-----------------
-- Size_Clause --
-----------------
@@ -7783,6 +7839,7 @@
W ("Is_Internal", Flag17 (Id));
W ("Is_Interrupt_Handler", Flag89 (Id));
W ("Is_Intrinsic_Subprogram", Flag64 (Id));
+ W ("Is_Invariant_Procedure", Flag257 (Id));
W ("Is_Itype", Flag91 (Id));
W ("Is_Known_Non_Null", Flag37 (Id));
W ("Is_Known_Null", Flag204 (Id));
@@ -7800,6 +7857,8 @@
W ("Is_Packed", Flag51 (Id));
W ("Is_Packed_Array_Type", Flag138 (Id));
W ("Is_Potentially_Use_Visible", Flag9 (Id));
+ W ("Is_Predicate_Function", Flag255 (Id));
+ W ("Is_Predicate_Function_M", Flag256 (Id));
W ("Is_Preelaborated", Flag59 (Id));
W ("Is_Primitive", Flag218 (Id));
W ("Is_Primitive_Wrapper", Flag195 (Id));
Index: einfo.ads
===================================================================
--- einfo.ads (revision 197743)
+++ einfo.ads (working copy)
@@ -1587,9 +1587,7 @@
-- True, then usually the Invariant_Procedure attribute is set once the
-- type is frozen, however this may not be true in some error situations.
-- Note that it might be the full type which has inheritable invariants,
--- and then the flag will also be set in the private type. Also set in
--- the invariant procedure entity, to distinguish it among entries in the
--- Subprograms_For_Type.
+-- and then the flag will also be set in the private type.
-- Has_Machine_Radix_Clause (Flag83)
-- Defined in decimal types and subtypes, set if a Machine_Radix
@@ -1731,11 +1729,9 @@
-- such an object and no warning is generated.
-- Has_Predicates (Flag250)
--- Defined 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.
+-- Defined in type and subtype entities. Set if a pragma Predicate or
+-- Predicate aspect applies to the type or subtype, or if it inherits a
+-- Predicate aspect from its parent or progenitor types.
-- Has_Primitive_Operations (Flag120) [base type only]
-- Defined in all type entities. Set if at least one primitive operation
@@ -2406,6 +2402,10 @@
-- setting of Is_Intrinsic_Subprogram, NOT simply having convention set
-- to intrinsic, which causes intrinsic code to be generated.
+-- Is_Invariant_Procedure (Flag257)
+-- Defined in functions an procedures. Set for a generated invariant
+-- procedure to identify it easily in the
+
-- Is_Itype (Flag91)
-- Defined in all entities. Set to indicate that a type is an Itype,
-- which means that the declaration for the type does not appear
@@ -2637,6 +2637,15 @@
-- use clause (RM 8.4(8)). Note that potentially use visible entities
-- are not necessarily use visible (RM 8.4(9-11)).
+-- Is_Predicate_Function (Flag255)
+-- Present in functions and procedures. Set for generated predicate
+-- functions.
+
+-- Is_Predicate_Function_M (Flag256)
+-- Present in functions and procedures. Set for special version of
+-- predicate function generated for use in membership tests, where
+-- raise expressions are transformed to return False.
+
-- Is_Preelaborated (Flag59)
-- Defined in all entities, set in E_Package and E_Generic_Package
-- entities to which a pragma Preelaborate is applied, and also in
@@ -3384,6 +3393,12 @@
-- Note: the reason this is marked as a synthesized attribute is that the
-- way this is stored is as an element of the Subprograms_For_Type field.
+-- Predicate_Function_M (synthesized)
+-- Defined in all types. Present only if Predicate_Function is present,
+-- and only if the predicate function has Raise_Expression nodes. It
+-- is the special version created for membership tests, where if one of
+-- these raise expressions is executed, the result is to return False.
+
-- Primitive_Operations (synthesized)
-- Defined in concurrent types, tagged record types and subtypes, tagged
-- private types and tagged incomplete types. For concurrent types whose
@@ -4844,7 +4859,6 @@
-- 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)
@@ -4961,6 +4975,7 @@
-- 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)
@@ -5006,6 +5021,7 @@
-- Invariant_Procedure (synth)
-- Is_Access_Protected_Subprogram_Type (synth)
-- Predicate_Function (synth)
+ -- Predicate_Function_M (synth)
-- Root_Type (synth)
-- Size_Clause (synth)
@@ -5360,7 +5376,10 @@
-- Is_Eliminated (Flag124)
-- Is_Instantiated (Flag126) (generic case only)
-- Is_Intrinsic_Subprogram (Flag64)
+ -- Is_Invariant_Procedure (Flag257) (non-generic case only)
-- Is_Machine_Code_Subprogram (Flag137) (non-generic case only)
+ -- Is_Predicate_Function (Flag255) (non-generic case only)
+ -- Is_Predicate_Function_M (Flag256) (non-generic case only)
-- Is_Primitive (Flag218)
-- Is_Primitive_Wrapper (Flag195) (non-generic case only)
-- Is_Private_Descendant (Flag53)
@@ -5629,8 +5648,11 @@
-- Is_Instantiated (Flag126) (generic case only)
-- Is_Interrupt_Handler (Flag89)
-- Is_Intrinsic_Subprogram (Flag64)
+ -- Is_Invariant_Procedure (Flag257) (non-generic case only)
-- Is_Machine_Code_Subprogram (Flag137) (non-generic case only)
-- Is_Null_Init_Proc (Flag178)
+ -- Is_Predicate_Function (Flag255) (non-generic case only)
+ -- Is_Predicate_Function_M (Flag256) (non-generic case only)
-- Is_Primitive (Flag218)
-- Is_Primitive_Wrapper (Flag195) (non-generic case only)
-- Is_Private_Descendant (Flag53)
@@ -6327,6 +6349,7 @@
function Is_Internal (Id : E) return B;
function Is_Interrupt_Handler (Id : E) return B;
function Is_Intrinsic_Subprogram (Id : E) return B;
+ function Is_Invariant_Procedure (Id : E) return B;
function Is_Itype (Id : E) return B;
function Is_Known_Non_Null (Id : E) return B;
function Is_Known_Null (Id : E) return B;
@@ -6344,6 +6367,8 @@
function Is_Packed (Id : E) return B;
function Is_Packed_Array_Type (Id : E) return B;
function Is_Potentially_Use_Visible (Id : E) return B;
+ function Is_Predicate_Function (Id : E) return B;
+ function Is_Predicate_Function_M (Id : E) return B;
function Is_Preelaborated (Id : E) return B;
function Is_Primitive (Id : E) return B;
function Is_Primitive_Wrapper (Id : E) return B;
@@ -6933,6 +6958,7 @@
procedure Set_Is_Internal (Id : E; V : B := True);
procedure Set_Is_Interrupt_Handler (Id : E; V : B := True);
procedure Set_Is_Intrinsic_Subprogram (Id : E; V : B := True);
+ procedure Set_Is_Invariant_Procedure (Id : E; V : B := True);
procedure Set_Is_Itype (Id : E; V : B := True);
procedure Set_Is_Known_Non_Null (Id : E; V : B := True);
procedure Set_Is_Known_Null (Id : E; V : B := True);
@@ -6951,6 +6977,8 @@
procedure Set_Is_Packed (Id : E; V : B := True);
procedure Set_Is_Packed_Array_Type (Id : E; V : B := True);
procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True);
+ procedure Set_Is_Predicate_Function (Id : E; V : B := True);
+ procedure Set_Is_Predicate_Function_M (Id : E; V : B := True);
procedure Set_Is_Preelaborated (Id : E; V : B := True);
procedure Set_Is_Primitive (Id : E; V : B := True);
procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True);
@@ -7104,9 +7132,11 @@
function Invariant_Procedure (Id : E) return N;
function Predicate_Function (Id : E) return N;
+ function Predicate_Function_M (Id : E) return N;
procedure Set_Invariant_Procedure (Id : E; V : E);
procedure Set_Predicate_Function (Id : E; V : E);
+ procedure Set_Predicate_Function_M (Id : E; V : E);
-----------------------------------
-- Field Initialization Routines --
@@ -7649,6 +7679,7 @@
pragma Inline (Is_Internal);
pragma Inline (Is_Interrupt_Handler);
pragma Inline (Is_Intrinsic_Subprogram);
+ pragma Inline (Is_Invariant_Procedure);
pragma Inline (Is_Itype);
pragma Inline (Is_Known_Non_Null);
pragma Inline (Is_Known_Null);
@@ -7673,6 +7704,8 @@
pragma Inline (Is_Packed);
pragma Inline (Is_Packed_Array_Type);
pragma Inline (Is_Potentially_Use_Visible);
+ pragma Inline (Is_Predicate_Function);
+ pragma Inline (Is_Predicate_Function_M);
pragma Inline (Is_Preelaborated);
pragma Inline (Is_Primitive);
pragma Inline (Is_Primitive_Wrapper);
@@ -8074,6 +8107,7 @@
pragma Inline (Set_Is_Internal);
pragma Inline (Set_Is_Interrupt_Handler);
pragma Inline (Set_Is_Intrinsic_Subprogram);
+ pragma Inline (Set_Is_Invariant_Procedure);
pragma Inline (Set_Is_Itype);
pragma Inline (Set_Is_Known_Non_Null);
pragma Inline (Set_Is_Known_Null);
@@ -8092,6 +8126,8 @@
pragma Inline (Set_Is_Packed);
pragma Inline (Set_Is_Packed_Array_Type);
pragma Inline (Set_Is_Potentially_Use_Visible);
+ pragma Inline (Set_Is_Predicate_Function);
+ pragma Inline (Set_Is_Predicate_Function_M);
pragma Inline (Set_Is_Preelaborated);
pragma Inline (Set_Is_Primitive);
pragma Inline (Set_Is_Primitive_Wrapper);
Index: sem_res.adb
===================================================================
--- sem_res.adb (revision 197764)
+++ sem_res.adb (working copy)
@@ -3935,7 +3935,9 @@
-- infinite recursion.
if not (Ekind (Nam) = E_Function
- and then Has_Predicates (Nam))
+ and then (Is_Predicate_Function (Nam)
+ or else
+ Is_Predicate_Function_M (Nam)))
then
Apply_Predicate_Check (A, F_Typ);
end if;
@@ -9792,7 +9794,9 @@
if Has_Predicates (Target_Typ) then
if Nkind (Parent (N)) = N_Function_Call
and then Present (Name (Parent (N)))
- and then Has_Predicates (Entity (Name (Parent (N))))
+ and then (Is_Predicate_Function (Entity (Name (Parent (N))))
+ or else
+ Is_Predicate_Function_M (Entity (Name (Parent (N)))))
then
null;
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb (revision 197762)
+++ exp_ch4.adb (working copy)
@@ -6338,7 +6338,7 @@
Rewrite (N,
Make_And_Then (Loc,
Left_Opnd => Relocate_Node (N),
- Right_Opnd => Make_Predicate_Call (Rtyp, Lop)));
+ Right_Opnd => Make_Predicate_Call (Rtyp, Lop, Mem => True)));
-- Analyze new expression, mark left operand as analyzed to
-- avoid infinite recursion adding predicate calls. Similarly,
Index: exp_ch11.adb
===================================================================
--- exp_ch11.adb (revision 197764)
+++ exp_ch11.adb (working copy)
@@ -1450,22 +1450,40 @@
-- do
-- raise X [with string]
-- in
- -- raise Consraint_Error;
+ -- raise Constraint_Error;
+ -- unless the flag Convert_To_Return_False is set, in which case
+ -- the transformation is to:
+
+ -- do
+ -- return False;
+ -- in
+ -- raise Constraint_Error;
+
-- The raise constraint error can never be executed. It is just a dummy
-- node that can be labeled with an arbitrary type.
RCE := Make_Raise_Constraint_Error (Loc, Reason => CE_Explicit_Raise);
Set_Etype (RCE, Typ);
- Rewrite (N,
- Make_Expression_With_Actions (Loc,
- Actions => New_List (
- Make_Raise_Statement (Loc,
- Name => Name (N),
- Expression => Expression (N))),
- Expression => RCE));
+ if Convert_To_Return_False (N) then
+ Rewrite (N,
+ Make_Expression_With_Actions (Loc,
+ Actions => New_List (
+ Make_Simple_Return_Statement (Loc,
+ Expression => New_Occurrence_Of (Standard_False, Loc))),
+ Expression => RCE));
+ else
+ Rewrite (N,
+ Make_Expression_With_Actions (Loc,
+ Actions => New_List (
+ Make_Raise_Statement (Loc,
+ Name => Name (N),
+ Expression => Expression (N))),
+ Expression => RCE));
+ end if;
+
Analyze_And_Resolve (N, Typ);
end Expand_N_Raise_Expression;
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb (revision 197752)
+++ sem_ch13.adb (working copy)
@@ -82,7 +82,7 @@
-- type whose inherited alignment is no longer appropriate for the new
-- size value. In this case, we reset the Alignment to unknown.
- procedure Build_Predicate_Function (Typ : Entity_Id; N : Node_Id);
+ procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id);
-- If Typ has predicates (indicated by Has_Predicates being set for Typ,
-- then either there are pragma Predicate entries on the rep chain for the
-- type (note that Predicate aspects are converted to pragma Predicate), or
@@ -90,7 +90,9 @@
-- This procedure builds the spec and body for the Predicate function that
-- tests these predicates. N is the freeze node for the type. The spec of
-- the function is inserted before the freeze node, and the body of the
- -- function is inserted after the freeze node.
+ -- function is inserted after the freeze node. If the predicate expression
+ -- has at least one Raise_Expression, then this procedure also builds the
+ -- M version of the predicate function for ue in membership tests.
procedure Build_Static_Predicate
(Typ : Entity_Id;
@@ -4689,12 +4691,12 @@
-- If we have a type with predicates, build predicate function
if Is_Type (E) and then Has_Predicates (E) then
- Build_Predicate_Function (E, N);
+ Build_Predicate_Functions (E, N);
end if;
-- If type has delayed aspects, this is where we do the preanalysis at
-- the freeze point, as part of the consistent visibility check. Note
- -- that this must be done after calling Build_Predicate_Function or
+ -- that this must be done after calling Build_Predicate_Functions or
-- Build_Invariant_Procedure since these subprograms fix occurrences of
-- the subtype name in the saved expression so that they will not cause
-- trouble in the preanalysis.
@@ -5225,9 +5227,9 @@
SId :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Typ), "Invariant"));
- Set_Has_Invariants (SId);
Set_Has_Invariants (Typ);
Set_Ekind (SId, E_Procedure);
+ Set_Is_Invariant_Procedure (SId);
Set_Invariant_Procedure (Typ, SId);
Spec :=
@@ -5597,11 +5599,11 @@
end if;
end Build_Invariant_Procedure;
- ------------------------------
- -- Build_Predicate_Function --
- ------------------------------
+ -------------------------------
+ -- Build_Predicate_Functions --
+ -------------------------------
- -- The procedure that is constructed here has the form:
+ -- The procedures that are constructed here has the form:
-- function typPredicate (Ixxx : typ) return Boolean is
-- begin
@@ -5618,17 +5620,38 @@
-- inherited. Note that we do NOT generate Check pragmas, that's because we
-- use this function even if checks are off, e.g. for membership tests.
- procedure Build_Predicate_Function (Typ : Entity_Id; N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (Typ);
- Spec : Node_Id;
- SId : Entity_Id;
- FDecl : Node_Id;
- FBody : Node_Id;
+ -- If the expression has at least one Raise_Expression, then we also build
+ -- the typPredicateM version of the function, in which any occurence of a
+ -- Raise_Expressioon is converted to "return False".
+ procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Typ);
+
Expr : Node_Id;
- -- This is the expression for the return statement in the function. It
+ -- This is the expression for the result of the function. It is
-- is build by connecting the component predicates with AND THEN.
+ Expr_M : Node_Id;
+ -- This is the corresponding return expression for the Predicate_M
+ -- function. It differs in that raise expressions are marked for
+ -- special expansion (see Process_REs).
+
+ Object_Name : constant Name_Id := New_Internal_Name ('I');
+ -- Name for argument of Predicate procedure. Note that we use the same
+ -- name for both predicate procedure. That way the reference within the
+ -- predicate expression is the same in both functions.
+
+ Object_Entity : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Chars => Object_Name);
+ -- Entity for argument of Predicate procedure
+
+ Object_Entity_M : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Chars => Object_Name);
+ -- Entity for argument of Predicate_M procedure
+
+ Raise_Expression_Present : Boolean := False;
+ -- Set True if Expr has at least one Raise_Expression
+
procedure Add_Call (T : Entity_Id);
-- Includes a call to the predicate function for type T in Expr if T
-- has predicates and Predicate_Function (T) is non-empty.
@@ -5639,13 +5662,20 @@
-- Inheritance of predicates for the parent type is done by calling the
-- Predicate_Function of the parent type, using Add_Call above.
- Object_Name : constant Name_Id := New_Internal_Name ('I');
- -- Name for argument of Predicate procedure
+ function Test_RE (N : Node_Id) return Traverse_Result;
+ -- Used in Test_REs, tests one node for being a raise expression, and if
+ -- so sets Raise_Expression_Present True.
- Object_Entity : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Object_Name);
- -- The entity for the spec entity for the argument
+ procedure Test_REs is new Traverse_Proc (Test_RE);
+ -- Tests to see if Expr contains any raise expressions
+ function Process_RE (N : Node_Id) return Traverse_Result;
+ -- Used in Process REs, tests if node N is a raise expression, and if
+ -- so, marks it to be converted to return False.
+
+ procedure Process_REs is new Traverse_Proc (Process_RE);
+ -- Marks any raise expressions in Expr_M to return False
+
Dynamic_Predicate_Present : Boolean := False;
-- Set True if a dynamic predicate is present, results in the entire
-- predicate being considered dynamic even if it looks static
@@ -5730,8 +5760,8 @@
Rewrite (N, Make_Identifier (Sloc (N), Object_Name));
-- Use the Sloc of the usage name, not the defining name
+ Set_Etype (N, Typ);
Set_Entity (N, Object_Entity);
- Set_Etype (N, Typ);
-- We want to treat the node as if it comes from source, so that
-- ASIS will not ignore it
@@ -5830,13 +5860,37 @@
end loop;
end Add_Predicates;
- -- Start of processing for Build_Predicate_Function
+ ----------------
+ -- Process_RE --
+ ----------------
- begin
- -- Initialize for construction of statement list
+ function Process_RE (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) = N_Raise_Expression then
+ Set_Convert_To_Return_False (N);
+ return Skip;
+ else
+ return OK;
+ end if;
+ end Process_RE;
- Expr := Empty;
+ -------------
+ -- Test_RE --
+ -------------
+ function Test_RE (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) = N_Raise_Expression then
+ Raise_Expression_Present := True;
+ return Abandon;
+ else
+ return OK;
+ end if;
+ end Test_RE;
+
+ -- Start of processing for Build_Predicate_Functions
+
+ begin
-- Return if already built or if type does not have predicates
if not Has_Predicates (Typ)
@@ -5845,6 +5899,10 @@
return;
end if;
+ -- Prepare to construct predicate expression
+
+ Expr := Empty;
+
-- Add Predicates for the current type
Add_Predicates;
@@ -5859,70 +5917,199 @@
end if;
end;
- -- If we have predicates, build the function
+ -- Case where predicates are present
if Present (Expr) then
- -- Build function declaration
+ -- Test for raise expression present
- SId :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Typ), "Predicate"));
- Set_Has_Predicates (SId);
- Set_Ekind (SId, E_Function);
- Set_Predicate_Function (Typ, SId);
+ Test_REs (Expr);
- -- The predicate function is shared between views of a type.
+ -- If raise expression is present, capture a copy of Expr for use
+ -- in building the predicateM function version later on. For this
+ -- copy we replace references to Object_Entity by Object_Entity_M.
- if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
- Set_Predicate_Function (Full_View (Typ), SId);
+ if Raise_Expression_Present then
+ declare
+ Map : constant Elist_Id := New_Elmt_List;
+ begin
+ Append_Elmt (Object_Entity, Map);
+ Append_Elmt (Object_Entity_M, Map);
+ Expr_M := New_Copy_Tree (Expr, Map => Map);
+ end;
end if;
- Spec :=
- Make_Function_Specification (Loc,
- Defining_Unit_Name => SId,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Object_Entity,
- Parameter_Type => New_Occurrence_Of (Typ, Loc))),
- Result_Definition =>
- New_Occurrence_Of (Standard_Boolean, Loc));
+ -- Build the main predicate function
- FDecl := Make_Subprogram_Declaration (Loc, Specification => Spec);
+ declare
+ SId : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Typ), "Predicate"));
+ -- The entity for the the function spec
- -- Build function body
+ SIdB : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Typ), "Predicate"));
+ -- The entity for the function body
- SId :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Typ), "Predicate"));
+ Spec : Node_Id;
+ FDecl : Node_Id;
+ FBody : Node_Id;
- Spec :=
- Make_Function_Specification (Loc,
- Defining_Unit_Name => SId,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Object_Name),
- Parameter_Type =>
- New_Occurrence_Of (Typ, Loc))),
- Result_Definition =>
- New_Occurrence_Of (Standard_Boolean, Loc));
+ begin
+ -- Build function declaration
- FBody :=
- Make_Subprogram_Body (Loc,
- Specification => Spec,
- Declarations => Empty_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Simple_Return_Statement (Loc,
- Expression => Expr))));
+ Set_Ekind (SId, E_Function);
+ Set_Is_Predicate_Function (SId);
+ Set_Predicate_Function (Typ, SId);
- -- Insert declaration before freeze node and body after
+ -- The predicate function is shared between views of a type
- Insert_Before_And_Analyze (N, FDecl);
- Insert_After_And_Analyze (N, FBody);
+ if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
+ Set_Predicate_Function (Full_View (Typ), SId);
+ end if;
+ Spec :=
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => SId,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Object_Entity,
+ Parameter_Type => New_Occurrence_Of (Typ, Loc))),
+ Result_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc));
+
+ FDecl :=
+ Make_Subprogram_Declaration (Loc,
+ Specification => Spec);
+
+ -- Build function body
+
+ Spec :=
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => SIdB,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Object_Name),
+ Parameter_Type =>
+ New_Occurrence_Of (Typ, Loc))),
+ Result_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc));
+
+ FBody :=
+ Make_Subprogram_Body (Loc,
+ Specification => Spec,
+ Declarations => Empty_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Simple_Return_Statement (Loc,
+ Expression => Expr))));
+
+ -- Insert declaration before freeze node and body after
+
+ Insert_Before_And_Analyze (N, FDecl);
+ Insert_After_And_Analyze (N, FBody);
+ end;
+
+ -- Test for raise expressions present and if so build M version
+
+ if Raise_Expression_Present then
+ declare
+ SId : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Typ), "PredicateM"));
+ -- The entity for the the function spec
+
+ SIdB : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Typ), "PredicateM"));
+ -- The entity for the function body
+
+ Spec : Node_Id;
+ FDecl : Node_Id;
+ FBody : Node_Id;
+ BTemp : Entity_Id;
+
+ begin
+ -- Mark any raise expressions for special expansion
+
+ Process_REs (Expr_M);
+
+ -- Build function declaration
+
+ Set_Ekind (SId, E_Function);
+ Set_Is_Predicate_Function_M (SId);
+ Set_Predicate_Function_M (Typ, SId);
+
+ -- The predicate function is shared between views of a type
+
+ if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
+ Set_Predicate_Function_M (Full_View (Typ), SId);
+ end if;
+
+ Spec :=
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => SId,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Object_Entity_M,
+ Parameter_Type => New_Occurrence_Of (Typ, Loc))),
+ Result_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc));
+
+ FDecl :=
+ Make_Subprogram_Declaration (Loc,
+ Specification => Spec);
+
+ -- Build function body
+
+ Spec :=
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => SIdB,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Object_Name),
+ Parameter_Type =>
+ New_Occurrence_Of (Typ, Loc))),
+ Result_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc));
+
+ -- Build the body, we declare the boolean expression before
+ -- doing the return, because we are not really confident of
+ -- what happens if a return appears within a return!
+
+ BTemp :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('B'));
+
+ FBody :=
+ Make_Subprogram_Body (Loc,
+ Specification => Spec,
+
+ Declarations => New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => BTemp,
+ Constant_Present => True,
+ Object_Definition =>
+ New_Reference_To (Standard_Boolean, Loc),
+ Expression => Expr_M)),
+
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Simple_Return_Statement (Loc,
+ Expression => New_Reference_To (BTemp, Loc)))));
+
+ -- Insert declaration before freeze node and body after
+
+ Insert_Before_And_Analyze (N, FDecl);
+ Insert_After_And_Analyze (N, FBody);
+ end;
+ end if;
+
-- Deal with static predicate case
if Ekind_In (Typ, E_Enumeration_Subtype,
@@ -5944,7 +6131,7 @@
end if;
end if;
end if;
- end Build_Predicate_Function;
+ end Build_Predicate_Functions;
----------------------------
-- Build_Static_Predicate --
@@ -6449,7 +6636,10 @@
declare
Ent : constant Entity_Id := Entity (Name (Exp));
begin
- if Has_Predicates (Ent) then
+ if Is_Predicate_Function (Ent)
+ or else
+ Is_Predicate_Function_M (Ent)
+ then
return Stat_Pred (Etype (First_Formal (Ent)));
end if;
end;
Index: atree.h
===================================================================
--- atree.h (revision 197743)
+++ atree.h (working copy)
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2012, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2013, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -259,6 +259,45 @@
Boolean flag215 : 1;
};
+/* Structure used for extra flags in sixth component overlaying Field12 */
+struct Flag_Word5
+{
+ Boolean flag255 : 1;
+ Boolean flag256 : 1;
+ Boolean flag257 : 1;
+ Boolean flag258 : 1;
+ Boolean flag259 : 1;
+ Boolean flag260 : 1;
+ Boolean flag261 : 1;
+ Boolean flag262 : 1;
+
+ Boolean flag263 : 1;
+ Boolean flag264 : 1;
+ Boolean flag265 : 1;
+ Boolean flag266 : 1;
+ Boolean flag267 : 1;
+ Boolean flag268 : 1;
+ Boolean flag269 : 1;
+ Boolean flag270 : 1;
+
+ Boolean flag271 : 1;
+ Boolean flag272 : 1;
+ Boolean flag273 : 1;
+ Boolean flag274 : 1;
+ Boolean flag275 : 1;
+ Boolean flag276 : 1;
+ Boolean flag277 : 1;
+ Boolean flag278 : 1;
+
+ Boolean flag279 : 1;
+ Boolean flag280 : 1;
+ Boolean flag281 : 1;
+ Boolean flag282 : 1;
+ Boolean flag283 : 1;
+ Boolean flag284 : 1;
+ Boolean flag285 : 1;
+ Boolean flag286 : 1;
+};
struct Non_Extended
{
Source_Ptr sloc;
@@ -290,6 +329,7 @@
struct Flag_Word fw;
struct Flag_Word2 fw2;
struct Flag_Word4 fw4;
+ struct Flag_Word5 fw5;
} U;
};
@@ -387,7 +427,12 @@
#define Field27(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field9)
#define Field28(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field10)
#define Field29(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.X.field11)
-#define Field30(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field6)
+#define Field30(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.field6)
+#define Field31(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.field7)
+#define Field32(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.field8)
+#define Field33(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.field9)
+#define Field34(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.field10)
+#define Field35(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.X.field11)
#define Node1(N) Field1 (N)
#define Node2(N) Field2 (N)
@@ -419,6 +464,12 @@
#define Node28(N) Field28 (N)
#define Node29(N) Field29 (N)
#define Node30(N) Field30 (N)
+#define Node31(N) Field31 (N)
+#define Node32(N) Field32 (N)
+#define Node33(N) Field33 (N)
+#define Node34(N) Field34 (N)
+#define Node35(N) Field35 (N)
+#define Node36(N) Field36 (N)
#define List1(N) Field1 (N)
#define List2(N) Field2 (N)
@@ -742,6 +793,39 @@
#define Flag253(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.NK.flag71)
#define Flag254(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.NK.flag72)
+#define Flag255(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag255)
+#define Flag256(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag256)
+#define Flag257(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag257)
+#define Flag258(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag258)
+#define Flag259(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag259)
+#define Flag260(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag260)
+#define Flag261(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag261)
+#define Flag262(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag262)
+#define Flag263(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag263)
+#define Flag264(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag264)
+#define Flag265(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag265)
+#define Flag266(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag266)
+#define Flag267(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag267)
+#define Flag268(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag268)
+#define Flag269(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag269)
+#define Flag270(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag270)
+#define Flag271(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag271)
+#define Flag272(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag272)
+#define Flag273(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag273)
+#define Flag274(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag274)
+#define Flag275(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag275)
+#define Flag276(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag276)
+#define Flag277(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag277)
+#define Flag278(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag278)
+#define Flag279(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag279)
+#define Flag280(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag280)
+#define Flag281(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag281)
+#define Flag282(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag282)
+#define Flag283(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag283)
+#define Flag284(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag284)
+#define Flag285(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag285)
+#define Flag286(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag286)
+
#ifdef __cplusplus
}
#endif
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb (revision 197743)
+++ exp_ch3.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -7675,7 +7675,7 @@
if not Has_Invariants (Typ) then
Set_Has_Invariants (Typ);
- Set_Has_Invariants (Proc_Id);
+ Set_Is_Invariant_Procedure (Proc_Id);
Set_Invariant_Procedure (Typ, Proc_Id);
Insert_After (N, Proc);
Analyze (Proc);
