===================================================================
@@ -3998,6 +3998,9 @@ package body Exp_Util is
Typ : constant Entity_Id := Etype (Expr);
begin
+ pragma Assert
+ (Has_Invariants (Typ) and then Present (Invariant_Procedure (Typ)));
+
if Check_Enabled (Name_Invariant)
or else
Check_Enabled (Name_Assertion)
===================================================================
@@ -230,7 +230,7 @@ package body Einfo is
-- Extra_Formals Node28
-- Underlying_Record_View Node28
- -- Invariant_Procedure Node29
+ -- Subprograms_For_Type Node29
---------------------------------------------
-- Usage of Flags in Defining Entity Nodes --
@@ -513,8 +513,8 @@ package body Einfo is
-- OK_To_Rename Flag247
-- Has_Inheritable_Invariants Flag248
-- OK_To_Reference Flag249
+ -- Has_Predicates Flag250
- -- (unused) Flag250
-- (unused) Flag251
-- (unused) Flag252
-- (unused) Flag253
@@ -1287,7 +1287,7 @@ package body Einfo is
function Has_Invariants (Id : E) return B is
begin
- pragma Assert (Is_Type (Id));
+ pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Procedure);
return Flag232 (Id);
end Has_Invariants;
@@ -1409,6 +1409,12 @@ package body Einfo is
return Flag212 (Id);
end Has_Pragma_Unreferenced_Objects;
+ function Has_Predicates (Id : E) return B is
+ begin
+ pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Procedure);
+ return Flag250 (Id);
+ end Has_Predicates;
+
function Has_Primitive_Operations (Id : E) return B is
begin
pragma Assert (Is_Type (Id));
@@ -1566,12 +1572,6 @@ package body Einfo is
return Elist25 (Id);
end Interfaces;
- function Invariant_Procedure (Id : E) return N is
- begin
- pragma Assert (Is_Type (Id));
- return Node29 (Id);
- end Invariant_Procedure;
-
function In_Package_Body (Id : E) return B is
begin
return Flag48 (Id);
@@ -2651,6 +2651,12 @@ package body Einfo is
return Node15 (Id);
end String_Literal_Low_Bound;
+ function Subprograms_For_Type (Id : E) return E is
+ begin
+ pragma Assert (Is_Type (Id) or else Is_Subprogram (Id));
+ return Node29 (Id);
+ end Subprograms_For_Type;
+
function Suppress_Elaboration_Warnings (Id : E) return B is
begin
return Flag148 (Id);
@@ -3722,7 +3728,9 @@ package body Einfo is
procedure Set_Has_Invariants (Id : E; V : B := True) is
begin
- pragma Assert (Is_Type (Id));
+ pragma Assert (Is_Type (Id)
+ or else Ekind (Id) = E_Procedure
+ or else Ekind (Id) = E_Void);
Set_Flag232 (Id, V);
end Set_Has_Invariants;
@@ -3853,6 +3861,14 @@ package body Einfo is
Set_Flag212 (Id, V);
end Set_Has_Pragma_Unreferenced_Objects;
+ procedure Set_Has_Predicates (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Type (Id)
+ or else Ekind (Id) = E_Procedure
+ or else Ekind (Id) = E_Void);
+ Set_Flag250 (Id, V);
+ end Set_Has_Predicates;
+
procedure Set_Has_Primitive_Operations (Id : E; V : B := True) is
begin
pragma Assert (Id = Base_Type (Id));
@@ -4012,12 +4028,6 @@ package body Einfo is
Set_Elist25 (Id, V);
end Set_Interfaces;
- procedure Set_Invariant_Procedure (Id : E; V : N) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Node29 (Id, V);
- end Set_Invariant_Procedure;
-
procedure Set_In_Package_Body (Id : E; V : B := True) is
begin
Set_Flag48 (Id, V);
@@ -5146,6 +5156,12 @@ package body Einfo is
Set_Node15 (Id, V);
end Set_String_Literal_Low_Bound;
+ procedure Set_Subprograms_For_Type (Id : E; V : E) is
+ begin
+ pragma Assert (Is_Type (Id) or else Is_Subprogram (Id));
+ Set_Node29 (Id, V);
+ end Set_Subprograms_For_Type;
+
procedure Set_Suppress_Elaboration_Warnings (Id : E; V : B := True) is
begin
Set_Flag148 (Id, V);
@@ -6129,6 +6145,33 @@ package body Einfo is
end if;
end Implementation_Base_Type;
+ -------------------------
+ -- Invariant_Procedure --
+ -------------------------
+
+ function Invariant_Procedure (Id : E) return E is
+ S : Entity_Id;
+
+ begin
+ pragma Assert (Is_Type (Id) and then Has_Invariants (Id));
+
+ if No (Subprograms_For_Type (Id)) then
+ return Empty;
+
+ else
+ S := Subprograms_For_Type (Id);
+ while Present (S) loop
+ if Has_Invariants (S) then
+ return S;
+ else
+ S := Subprograms_For_Type (S);
+ end if;
+ end loop;
+
+ return Empty;
+ end if;
+ end Invariant_Procedure;
+
---------------------
-- Is_Boolean_Type --
---------------------
@@ -6222,6 +6265,33 @@ package body Einfo is
Ekind (Id) = E_Generic_Package;
end Is_Package_Or_Generic_Package;
+ -------------------------
+ -- Predicate_Procedure --
+ -------------------------
+
+ function Predicate_Procedure (Id : E) return E is
+ S : Entity_Id;
+
+ begin
+ pragma Assert (Is_Type (Id) and then Has_Predicates (Id));
+
+ if No (Subprograms_For_Type (Id)) then
+ return Empty;
+
+ else
+ S := Subprograms_For_Type (Id);
+ while Present (S) loop
+ if Has_Predicates (S) then
+ return S;
+ else
+ S := Subprograms_For_Type (S);
+ end if;
+ end loop;
+
+ return Empty;
+ end if;
+ end Predicate_Procedure;
+
---------------
-- Is_Prival --
---------------
@@ -6766,6 +6836,54 @@ package body Einfo is
end case;
end Set_Component_Alignment;
+ -----------------------------
+ -- Set_Invariant_Procedure --
+ -----------------------------
+
+ procedure Set_Invariant_Procedure (Id : E; V : E) is
+ S : Entity_Id;
+
+ begin
+ pragma Assert (Is_Type (Id) and then Has_Invariants (Id));
+
+ S := Subprograms_For_Type (Id);
+ Set_Subprograms_For_Type (Id, V);
+
+ while Present (S) loop
+ if Has_Invariants (S) then
+ raise Program_Error;
+ else
+ S := Subprograms_For_Type (S);
+ end if;
+ end loop;
+
+ Set_Subprograms_For_Type (Id, V);
+ end Set_Invariant_Procedure;
+
+ -----------------------------
+ -- Set_Predicate_Procedure --
+ -----------------------------
+
+ procedure Set_Predicate_Procedure (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);
+
+ while Present (S) loop
+ if Has_Predicates (S) then
+ raise Program_Error;
+ else
+ S := Subprograms_For_Type (S);
+ end if;
+ end loop;
+
+ Set_Subprograms_For_Type (Id, V);
+ end Set_Predicate_Procedure;
+
-----------------
-- Size_Clause --
-----------------
@@ -7063,6 +7181,7 @@ package body Einfo is
W ("Has_Pragma_Unmodified", Flag233 (Id));
W ("Has_Pragma_Unreferenced", Flag180 (Id));
W ("Has_Pragma_Unreferenced_Objects", Flag212 (Id));
+ W ("Has_Predicates", Flag250 (Id));
W ("Has_Primitive_Operations", Flag120 (Id));
W ("Has_Private_Declaration", Flag155 (Id));
W ("Has_Qualified_Name", Flag161 (Id));
@@ -8246,9 +8365,6 @@ package body Einfo is
procedure Write_Field28_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when Private_Kind =>
- Write_Str ("Invariant_Procedure");
-
when E_Procedure | E_Function | E_Entry =>
Write_Str ("Extra_Formals");
@@ -8264,7 +8380,7 @@ package body Einfo is
begin
case Ekind (Id) is
when Type_Kind =>
- Write_Str ("Invariant_Procedure");
+ Write_Str ("Subprograms_For_Type");
when others =>
Write_Str ("Field29??");
===================================================================
@@ -1507,14 +1507,16 @@ package Einfo is
-- Interrupt_Handler applies.
-- Has_Invariants (Flag232)
+-- Present in all type entities and in subprogram entities. Set True in
+-- private types if an Invariant or Invariant'Class aspect applies to the
+-- type, or if the type inherits one or more Invariant'Class aspects.
+-- Also set in the corresponding full type. Note: if this flag is set
+-- 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.
-- Has_Inheritable_Invariants (Flag248)
-- Present in all type entities. Set True in private types from which one
@@ -1671,6 +1673,13 @@ package Einfo is
-- (but unlike the case with pragma Unreferenced, it is ok to reference
-- 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 procedure 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
-- is defined for the type.
@@ -1900,15 +1909,18 @@ package Einfo is
-- External_Name of the imported Java field (which is generally needed,
-- because Java names are case sensitive).
+-- Invariant_Procedure (synthesized)
-- Present in types and subtypes. Set for private types if one or more
-- Invariant, or Invariant'Class, or inherited Invariant'Class aspects
-- apply to the type. Points to the entity for a procedure which checks
-- the invariant. This invariant procedure takes a single argument of the
-- given type, and returns if the invariant holds, or raises exception
-- Assertion_Error with an appropriate message if it does not hold. This
+-- attribute is present but always empty for private subtypes. This
+-- attribute is also set for the corresponding full type.
+--
+-- 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.
-- In_Use (Flag8)
-- Present in packages and types. Set when analyzing a use clause for
@@ -3264,6 +3276,17 @@ package Einfo is
-- Direct_Primitive_Operations of its CRT; otherwise returns No_Elist.
-- For all the other types returns the Direct_Primitive_Operations.
+-- Predicate_Procedure (synthesized)
+-- Present in all types. Set for types for which (Has_Predicates is True)
+-- and for which a predicate procedure has been built that tests that the
+-- specified predicates are True. Contains the entity for the procedure
+-- which takes a single argument of the given type, and returns if the
+-- predicate holds, or raises exception Assertion_Error with an exception
+-- message if it does not hold.
+--
+-- 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.
+
-- Prival (Node17)
-- Present in private components of protected types. Refers to the entity
-- of the component renaming declaration generated inside protected
@@ -3632,6 +3655,16 @@ package Einfo is
-- the low bound of the applicable index constraint if there is one,
-- or a copy of the low bound of the index base type if not.
+-- Subprograms_For_Type (Node29)
+-- Present in all type entities, and in subprogram entities. This is used
+-- to hold a list of subprogram entities for subprograms associated with
+-- the type, linked through the Suprogram_List field of the subprogram
+-- entity. Basically this is a way of multiplexing the single field to
+-- hold more than one entity (since we ran out of space in some type
+-- entities). This is currently used for Invariant_Procedure and also
+-- for Predicate_Procedure, and clients will always use the latter two
+-- names to access entries in this list.
+
-- Suppress_Elaboration_Warnings (Flag148)
-- Present in all entities, can be set only for subprogram entities and
-- for variables. If this flag is set then Sem_Elab will not generate
@@ -4733,7 +4766,7 @@ package Einfo is
-- Alignment (Uint14)
-- Related_Expression (Node24)
-- Current_Use_Clause (Node27)
- -- Invariant_Procedure (Node29)
+ -- Subprograms_For_Type (Node29)
-- Depends_On_Private (Flag14)
-- Discard_Names (Flag88)
@@ -4752,6 +4785,7 @@ 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)
@@ -4796,7 +4830,9 @@ package Einfo is
-- Base_Type (synth)
-- Has_Private_Ancestor (synth)
-- Implementation_Base_Type (synth)
+ -- Invariant_Procedure (synth)
-- Is_Access_Protected_Subprogram_Type (synth)
+ -- Predicate_Procedure (synth)
-- Root_Type (synth)
-- Size_Clause (synth)
@@ -5095,6 +5131,7 @@ package Einfo is
-- Overridden_Operation (Node26)
-- Wrapped_Entity (Node27) (non-generic case only)
-- Extra_Formals (Node28)
+ -- Subprograms_For_Type (Node29)
-- Body_Needed_For_SAL (Flag40)
-- Elaboration_Entity_Required (Flag174)
-- Default_Expressions_Processed (Flag108)
@@ -5103,10 +5140,12 @@ package Einfo is
-- Discard_Names (Flag88)
-- Has_Completion (Flag26)
-- Has_Controlling_Result (Flag98)
+ -- Has_Invariants (Flag232)
-- Has_Master_Entity (Flag21)
-- 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)
@@ -5236,7 +5275,10 @@ package Einfo is
-- First_Entity (Node17)
-- Alias (Node18)
-- Last_Entity (Node20)
+ -- 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)
@@ -5364,9 +5406,11 @@ package Einfo is
-- Delay_Subprogram_Descriptors (Flag50)
-- Discard_Names (Flag88)
-- Has_Completion (Flag26)
+ -- Has_Invariants (Flag232)
-- 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)
@@ -5965,6 +6009,7 @@ package Einfo is
function Has_Pragma_Unmodified (Id : E) return B;
function Has_Pragma_Unreferenced (Id : E) return B;
function Has_Pragma_Unreferenced_Objects (Id : E) return B;
+ function Has_Predicates (Id : E) return B;
function Has_Primitive_Operations (Id : E) return B;
function Has_Qualified_Name (Id : E) return B;
function Has_RACW (Id : E) return B;
@@ -5996,7 +6041,6 @@ package Einfo is
function Interface_Alias (Id : E) return E;
function Interfaces (Id : E) return L;
function Interface_Name (Id : E) return N;
- function Invariant_Procedure (Id : E) return N;
function Is_AST_Entry (Id : E) return B;
function Is_Abstract_Subprogram (Id : E) return B;
function Is_Abstract_Type (Id : E) return B;
@@ -6179,6 +6223,7 @@ package Einfo is
function Strict_Alignment (Id : E) return B;
function String_Literal_Length (Id : E) return U;
function String_Literal_Low_Bound (Id : E) return N;
+ function Subprograms_For_Type (Id : E) return E;
function Suppress_Elaboration_Warnings (Id : E) return B;
function Suppress_Init_Proc (Id : E) return B;
function Suppress_Style_Checks (Id : E) return B;
@@ -6531,6 +6576,7 @@ package Einfo is
procedure Set_Has_Pragma_Unmodified (Id : E; V : B := True);
procedure Set_Has_Pragma_Unreferenced (Id : E; V : B := True);
procedure Set_Has_Pragma_Unreferenced_Objects (Id : E; V : B := True);
+ procedure Set_Has_Predicates (Id : E; V : B := True);
procedure Set_Has_Primitive_Operations (Id : E; V : B := True);
procedure Set_Has_Private_Declaration (Id : E; V : B := True);
procedure Set_Has_Qualified_Name (Id : E; V : B := True);
@@ -6563,7 +6609,6 @@ package Einfo is
procedure Set_Inner_Instances (Id : E; V : L);
procedure Set_Interface_Alias (Id : E; V : E);
procedure Set_Interface_Name (Id : E; V : N);
- procedure Set_Invariant_Procedure (Id : E; V : N);
procedure Set_Is_AST_Entry (Id : E; V : B := True);
procedure Set_Is_Abstract_Subprogram (Id : E; V : B := True);
procedure Set_Is_Abstract_Type (Id : E; V : B := True);
@@ -6753,6 +6798,7 @@ package Einfo is
procedure Set_Strict_Alignment (Id : E; V : B := True);
procedure Set_String_Literal_Length (Id : E; V : U);
procedure Set_String_Literal_Low_Bound (Id : E; V : N);
+ procedure Set_Subprograms_For_Type (Id : E; V : E);
procedure Set_Suppress_Elaboration_Warnings (Id : E; V : B := True);
procedure Set_Suppress_Init_Proc (Id : E; V : B := True);
procedure Set_Suppress_Style_Checks (Id : E; V : B := True);
@@ -6773,6 +6819,16 @@ package Einfo is
procedure Set_Was_Hidden (Id : E; V : B := True);
procedure Set_Wrapped_Entity (Id : E; V : E);
+ ---------------------------------------------------
+ -- Access to Subprograms in Subprograms_For_Type --
+ ---------------------------------------------------
+
+ function Invariant_Procedure (Id : E) return N;
+ function Predicate_Procedure (Id : E) return N;
+
+ procedure Set_Invariant_Procedure (Id : E; V : E);
+ procedure Set_Predicate_Procedure (Id : E; V : E);
+
-----------------------------------
-- Field Initialization Routines --
-----------------------------------
@@ -7210,6 +7266,7 @@ package Einfo is
pragma Inline (Has_Pragma_Unmodified);
pragma Inline (Has_Pragma_Unreferenced);
pragma Inline (Has_Pragma_Unreferenced_Objects);
+ pragma Inline (Has_Predicates);
pragma Inline (Has_Primitive_Operations);
pragma Inline (Has_Private_Declaration);
pragma Inline (Has_Qualified_Name);
@@ -7243,7 +7300,6 @@ package Einfo is
pragma Inline (Inner_Instances);
pragma Inline (Interface_Alias);
pragma Inline (Interface_Name);
- pragma Inline (Invariant_Procedure);
pragma Inline (Is_AST_Entry);
pragma Inline (Is_Abstract_Subprogram);
pragma Inline (Is_Abstract_Type);
@@ -7475,6 +7531,7 @@ package Einfo is
pragma Inline (Strict_Alignment);
pragma Inline (String_Literal_Length);
pragma Inline (String_Literal_Low_Bound);
+ pragma Inline (Subprograms_For_Type);
pragma Inline (Suppress_Elaboration_Warnings);
pragma Inline (Suppress_Init_Proc);
pragma Inline (Suppress_Style_Checks);
@@ -7647,6 +7704,7 @@ package Einfo is
pragma Inline (Set_Has_Pragma_Unmodified);
pragma Inline (Set_Has_Pragma_Unreferenced);
pragma Inline (Set_Has_Pragma_Unreferenced_Objects);
+ pragma Inline (Set_Has_Predicates);
pragma Inline (Set_Has_Primitive_Operations);
pragma Inline (Set_Has_Private_Declaration);
pragma Inline (Set_Has_Qualified_Name);
@@ -7680,7 +7738,6 @@ package Einfo is
pragma Inline (Set_Inner_Instances);
pragma Inline (Set_Interface_Alias);
pragma Inline (Set_Interface_Name);
- pragma Inline (Set_Invariant_Procedure);
pragma Inline (Set_Is_AST_Entry);
pragma Inline (Set_Is_Abstract_Subprogram);
pragma Inline (Set_Is_Abstract_Type);
@@ -7868,6 +7925,7 @@ package Einfo is
pragma Inline (Set_Strict_Alignment);
pragma Inline (Set_String_Literal_Length);
pragma Inline (Set_String_Literal_Low_Bound);
+ pragma Inline (Set_Subprograms_For_Type);
pragma Inline (Set_Suppress_Elaboration_Warnings);
pragma Inline (Set_Suppress_Init_Proc);
pragma Inline (Set_Suppress_Style_Checks);
===================================================================
@@ -11166,6 +11166,51 @@ package body Sem_Prag is
end if;
end Precondition;
+ ---------------
+ -- Predicate --
+ ---------------
+
+ -- pragma Predicate
+ -- ([Entity =>] type_LOCAL_NAME,
+ -- [Check =>] EXPRESSION
+ -- [,[Message =>] String_Expression]);
+
+ when Pragma_Predicate => Predicate : declare
+ Type_Id : Node_Id;
+ Typ : Entity_Id;
+
+ Discard : Boolean;
+ pragma Unreferenced (Discard);
+
+ begin
+ GNAT_Pragma;
+ Check_At_Least_N_Arguments (2);
+ Check_At_Most_N_Arguments (3);
+ Check_Optional_Identifier (Arg1, Name_Entity);
+ Check_Optional_Identifier (Arg2, Name_Check);
+
+ if Arg_Count = 3 then
+ Check_Optional_Identifier (Arg3, Name_Message);
+ Check_Arg_Is_Static_Expression (Arg3, Standard_String);
+ end if;
+
+ Check_Arg_Is_Local_Name (Arg1);
+
+ Type_Id := Get_Pragma_Arg (Arg1);
+ Find_Type (Type_Id);
+ Typ := Entity (Type_Id);
+
+ if Typ = Any_Type then
+ return;
+ end if;
+
+ -- The remaining processing is simply to link the pragma on to
+ -- the rep item chain, for processing when the type is frozen.
+ -- This is accomplished by a call to Rep_Item_Too_Late.
+
+ Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
+ end Predicate;
+
------------------
-- Preelaborate --
------------------
@@ -13919,6 +13964,7 @@ package body Sem_Prag is
Pragma_Persistent_BSS => 0,
Pragma_Postcondition => -1,
Pragma_Precondition => -1,
+ Pragma_Predicate => -1,
Pragma_Preelaborate => -1,
Pragma_Preelaborate_05 => -1,
Pragma_Priority => -1,
===================================================================
@@ -8278,7 +8278,8 @@ package body Exp_Ch4 is
-- Note: the Comes_From_Source check, and then the resetting of this
-- flag prevents what would otherwise be an infinite recursion.
- if Present (Invariant_Procedure (Target_Type))
+ if Has_Invariants (Target_Type)
+ and then Present (Invariant_Procedure (Target_Type))
and then Comes_From_Source (N)
then
Set_Comes_From_Source (N, False);
===================================================================
@@ -9099,7 +9099,9 @@ package body Sem_Ch6 is
-- Add invariant call if returning type with invariants
- if Present (Invariant_Procedure (Etype (Rent))) then
+ if Has_Invariants (Etype (Rent))
+ and then Present (Invariant_Procedure (Etype (Rent)))
+ then
Append_To (Plist,
Make_Invariant_Call (New_Occurrence_Of (Rent, Loc)));
end if;
@@ -9121,6 +9123,7 @@ package body Sem_Ch6 is
Formal := First_Formal (Designator);
while Present (Formal) loop
if Ekind (Formal) /= E_In_Parameter
+ and then Has_Invariants (Etype (Formal))
and then Present (Invariant_Procedure (Etype (Formal)))
then
Append_To (Plist,
===================================================================
@@ -1205,6 +1205,7 @@ begin
Pragma_Persistent_BSS |
Pragma_Postcondition |
Pragma_Precondition |
+ Pragma_Predicate |
Pragma_Preelaborate |
Pragma_Preelaborate_05 |
Pragma_Priority |
===================================================================
@@ -635,7 +635,7 @@ package body Sem_Ch13 is
Ent : Node_Id;
Ins_Node : Node_Id := N;
- -- Insert pragmas (other than Pre/Post) after this node
+ -- Insert pragmas (except Pre/Post/Invariant/Predicate) after this node
-- The general processing involves building an attribute definition
-- clause or a pragma node that corresponds to the access type. Then
@@ -1008,13 +1008,14 @@ package body Sem_Ch13 is
goto Continue;
end;
- -- Invariant aspect generates an Invariant pragma with a first
- -- argument that is the entity, and the second argument is the
- -- expression. This is inserted right after the declaration, to
- -- get the required pragma placement. The processing for the
- -- pragma takes care of the required delay.
+ -- Invariant and Predicate aspects generate a corresponding
+ -- pragma with a first argument that is the entity, and the
+ -- second argument is the expression. This is inserted right
+ -- after the declaration, to get the required pragma placement.
+ -- The pragma processing takes care of the required delay.
- when Aspect_Invariant =>
+ when Aspect_Invariant |
+ Aspect_Predicate =>
-- Construct the pragma
@@ -1024,7 +1025,7 @@ package body Sem_Ch13 is
New_List (Ent, Relocate_Node (Expr)),
Class_Present => Class_Present (Aspect),
Pragma_Identifier =>
- Make_Identifier (Sloc (Id), Name_Invariant));
+ Make_Identifier (Sloc (Id), Chars (Id)));
-- Add message unless exception messages are suppressed
@@ -1040,18 +1041,13 @@ package body Sem_Ch13 is
Set_From_Aspect_Specification (Aitem, True);
- -- For Invariant case, insert immediately after the entity
- -- declaration. We do not have to worry about delay issues
- -- since the pragma processing takes care of this.
+ -- For Invariant and Predicate cases, insert immediately
+ -- after the entity declaration. We do not have to worry
+ -- about delay issues since the pragma processing takes
+ -- care of this.
Insert_After (N, Aitem);
goto Continue;
-
- -- Aspects currently unimplemented
-
- when Aspect_Predicate =>
- Error_Msg_N ("aspect& not implemented", Identifier (Aspect));
- goto Continue;
end case;
Set_From_Aspect_Specification (Aitem, True);
@@ -3685,9 +3681,11 @@ package body Sem_Ch13 is
-- Build procedure declaration
+ pragma Assert (Has_Invariants (Typ));
SId :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Typ), "Invariant"));
+ Set_Has_Invariants (SId);
Set_Invariant_Procedure (Typ, SId);
Spec :=
===================================================================
@@ -139,7 +139,6 @@ package Snames is
Name_Post : constant Name_Id := N + $;
Name_Pre : constant Name_Id := N + $;
- Name_Predicate : constant Name_Id := N + $;
-- Some special names used by the expander. Note that the lower case u's
-- at the start of these names get translated to extra underscores. These
@@ -507,6 +506,7 @@ package Snames is
Name_Passive : constant Name_Id := N + $; -- GNAT
Name_Postcondition : constant Name_Id := N + $; -- GNAT
Name_Precondition : constant Name_Id := N + $; -- GNAT
+ Name_Predicate : constant Name_Id := N + $; -- GNAT
Name_Preelaborable_Initialization : constant Name_Id := N + $; -- Ada 05
Name_Preelaborate : constant Name_Id := N + $;
Name_Preelaborate_05 : constant Name_Id := N + $; -- GNAT
@@ -1596,6 +1596,7 @@ package Snames is
Pragma_Passive,
Pragma_Postcondition,
Pragma_Precondition,
+ Pragma_Predicate,
Pragma_Preelaborable_Initialization,
Pragma_Preelaborate,
Pragma_Preelaborate_05,
===================================================================
@@ -4576,7 +4576,7 @@ package body Exp_Ch3 is
-- to clobber the object with an invalid value since if the exception
-- is raised, then the object will go out of scope.
- if Is_Private_Type (Typ)
+ if Has_Invariants (Typ)
and then Present (Invariant_Procedure (Typ))
then
Insert_After (N,