From f54f1dff2ff9c50f6403ff7d603db4dca4d8caa0 Mon Sep 17 00:00:00 2001 From: charlet Date: Thu, 21 Oct 2010 10:30:24 +0000 Subject: [PATCH] 2010-10-21 Robert Dewar * 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 * elists.adb: Minor reformatting. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@165763 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 16 +++++ gcc/ada/einfo.adb | 156 +++++++++++++++++++++++++++++++++++++++++------- gcc/ada/einfo.ads | 90 +++++++++++++++++++++++----- gcc/ada/elists.adb | 3 +- gcc/ada/exp_ch3.adb | 2 +- gcc/ada/exp_ch4.adb | 3 +- gcc/ada/exp_util.adb | 3 + gcc/ada/par-prag.adb | 1 + gcc/ada/sem_ch13.adb | 32 +++++----- gcc/ada/sem_ch6.adb | 5 +- gcc/ada/sem_prag.adb | 46 ++++++++++++++ gcc/ada/snames.ads-tmpl | 3 +- 12 files changed, 301 insertions(+), 59 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 90fd375..db58343 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,19 @@ +2010-10-21 Robert Dewar + + * 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 + + * elists.adb: Minor reformatting. + 2010-10-21 Geert Bosch * urealp.adb (UR_Write): Write hexadecimal constants with exponent 1 as diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index ca61c20..ca6bbf0 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -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??"); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index b79fa29..6eadc35 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -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); diff --git a/gcc/ada/elists.adb b/gcc/ada/elists.adb index c520b67..58beb00 100644 --- a/gcc/ada/elists.adb +++ b/gcc/ada/elists.adb @@ -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; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 8a79fb1..0cb2b5b 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -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, diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 361d854..d62703d 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -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); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index e919bd6..0caf92d 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -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) diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index a6f3826..f678c0d 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -1205,6 +1205,7 @@ begin Pragma_Persistent_BSS | Pragma_Postcondition | Pragma_Precondition | + Pragma_Predicate | Pragma_Preelaborate | Pragma_Preelaborate_05 | Pragma_Priority | diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 88acedf..ce0cb5b 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -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 := diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 0f2fce8..fe2e197 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -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, diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index ea8bb10..64388a8 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -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, diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 4ec549e..29cc172 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -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, -- 2.7.4