+2010-10-21 Robert Dewar <dewar@adacore.com>
+
+ * einfo.ads, einfo.adb: Add handling of predicates.
+ Rework handling of invariants.
+ * exp_ch3.adb, exp_ch4.adb, exp_util.adb, sem_ch6.adb: Minor changes to
+ handing of invariants.
+ * par-prag.adb: Add dummy entry for pragma Predicate
+ * sem_ch13.adb (Analyze_Aspect_Specifications): Add processing for
+ Predicate aspects.
+ * sem_prag.adb: Add implementation of pragma Predicate.
+ * snames.ads-tmpl: Add entries for pragma Predicate.
+
+2010-10-21 Robert Dewar <dewar@adacore.com>
+
+ * elists.adb: Minor reformatting.
+
2010-10-21 Geert Bosch <bosch@adacore.com>
* urealp.adb (UR_Write): Write hexadecimal constants with exponent 1 as
-- Extra_Formals Node28
-- Underlying_Record_View Node28
- -- Invariant_Procedure Node29
+ -- Subprograms_For_Type Node29
---------------------------------------------
-- Usage of Flags in Defining Entity Nodes --
-- OK_To_Rename Flag247
-- Has_Inheritable_Invariants Flag248
-- OK_To_Reference Flag249
+ -- Has_Predicates Flag250
- -- (unused) Flag250
-- (unused) Flag251
-- (unused) Flag252
-- (unused) Flag253
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;
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));
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);
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);
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;
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));
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);
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);
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 --
---------------------
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 --
---------------
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 --
-----------------
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));
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");
begin
case Ekind (Id) is
when Type_Kind =>
- Write_Str ("Invariant_Procedure");
+ Write_Str ("Subprograms_For_Type");
when others =>
Write_Str ("Field29??");
-- Interrupt_Handler applies.
-- Has_Invariants (Flag232)
--- Present in all type 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 field 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.
+-- 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
-- (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.
-- External_Name of the imported Java field (which is generally needed,
-- because Java names are case sensitive).
--- Invariant_Procedure (Node29)
+-- 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
--- field is present but always empty for private subtypes. This field is
--- also set for the corresponding full type.
+-- 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
-- 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
-- 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
-- Alignment (Uint14)
-- Related_Expression (Node24)
-- Current_Use_Clause (Node27)
- -- Invariant_Procedure (Node29)
+ -- Subprograms_For_Type (Node29)
-- Depends_On_Private (Flag14)
-- Discard_Names (Flag88)
-- 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)
-- 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)
-- 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)
-- 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)
-- 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)
-- 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)
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;
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;
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;
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);
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);
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);
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 --
-----------------------------------
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);
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);
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);
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);
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);
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);
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, 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- --
-- Case of removing only element in the list
if Elmts.Table (Nxt).Next in Elist_Range then
-
pragma Assert (Nxt = Elmt);
Elists.Table (List).First := No_Elmt;
-- 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,
-- 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);
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)
Pragma_Persistent_BSS |
Pragma_Postcondition |
Pragma_Precondition |
+ Pragma_Predicate |
Pragma_Preelaborate |
Pragma_Preelaborate_05 |
Pragma_Priority |
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
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
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
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);
-- 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 :=
-- 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;
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,
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 --
------------------
Pragma_Persistent_BSS => 0,
Pragma_Postcondition => -1,
Pragma_Precondition => -1,
+ Pragma_Predicate => -1,
Pragma_Preelaborate => -1,
Pragma_Preelaborate_05 => -1,
Pragma_Priority => -1,
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
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
Pragma_Passive,
Pragma_Postcondition,
Pragma_Precondition,
+ Pragma_Predicate,
Pragma_Preelaborable_Initialization,
Pragma_Preelaborate,
Pragma_Preelaborate_05,
projects / platform / upstream / linaro-gcc.git / commitdiff