OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

einfo.ads, einfo.adb: Add handling of predicates. 

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.

From-SVN: r165763
This commit is contained in:
Robert Dewar 2010-10-21 10:30:24 +00:00 committed by Arnaud Charlet
parent 04cbd48e9e
commit fd0ff1cf7e
12 changed files with 301 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
gcc/ada/ChangeLog
View File

@ -1,3 +1,19 @@
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

156
gcc/ada/einfo.adb
View File

@ -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??");

90
gcc/ada/einfo.ads
View File

@ -1507,14 +1507,16 @@ package Einfo is
-- 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
@ -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 (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
@ -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);

3
gcc/ada/elists.adb
View File

@ -6,7 +6,7 @@
-- --
-- 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- --
@ -389,7 +389,6 @@ package body Elists is
-- 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;

2
gcc/ada/exp_ch3.adb
View File

@ -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,

3
gcc/ada/exp_ch4.adb
View File

@ -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);

3
gcc/ada/exp_util.adb
View File

@ -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)

1
gcc/ada/par-prag.adb
View File

@ -1205,6 +1205,7 @@ begin
Pragma_Persistent_BSS |
Pragma_Postcondition |
Pragma_Precondition |
Pragma_Predicate |
Pragma_Preelaborate |
Pragma_Preelaborate_05 |
Pragma_Priority |

32
gcc/ada/sem_ch13.adb
View File

@ -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 :=

5
gcc/ada/sem_ch6.adb
View File

@ -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,

46
gcc/ada/sem_prag.adb
View File

@ -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,

3
gcc/ada/snames.ads-tmpl
View File

@ -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,