[gcc r11-5477] [Ada] Implement AI12-0187 (Stable properties of abstract data types)
Pierre-Marie de Rodat
pmderodat@gcc.gnu.org
Fri Nov 27 09:19:28 GMT 2020
https://gcc.gnu.org/g:23e3e22105723fde2a9161757611544f180ba805
commit r11-5477-g23e3e22105723fde2a9161757611544f180ba805
Author: Steve Baird <baird@adacore.com>
Date: Wed Oct 21 16:57:04 2020 -0700
[Ada] Implement AI12-0187 (Stable properties of abstract data types)
gcc/ada/
* snames.ads-tmpl: Define new Name_Stable_Properties Name_Id
value.
* aspects.ads, aspects.adb: Add new Aspect_Stable_Properties
enumeration literal to Aspect_Id type. Add Class_Present
parameter to Find_Aspect and related
functions (Find_Value_Of_Aspect and Has_Aspect).
* sem_util.adb (Has_Nontrivial_Precondition): Fix
previously-latent bug uncovered by adding Class_Present
parameter to Aspect.Find_Aspect. The code was wrong before, but
with the change the bug was more likely to make a user-visible
difference.
* sem_ch6.adb (Analyze_Operator_Symbol): If a string literal
like "abs" or "-" occurs in a Stable_Properties aspect
specification, then it is to be interpreted as an operator
symbol and not as a string literal.
* sem_ch13.ads: Export new Parse_Aspect_Stable_Properties
function, analogous to the existing Parse_Aspect_Aggregate
exported procedure.
* sem_ch13.adb: (Parse_Aspect_Stable_Properties): New function;
analogous to existing Parse_Aspect_Aggregate.
(Validate_Aspect_Stable_Properties): New procedure; analogous to
existing Validate_Aspect_Aggregate. Called from the same case
statement (casing on an Aspect_Id value) where
Validate_Aspect_Aggregate is called.
(Resolve_Aspect_Stable_Properties): New procedure; analogous to
existing Resolve_Aspect_Aggregate. Called from the same two case
statements (each casing on an Aspect_Id value) where
Resolve_Aspect_Aggregate is called.
(Analyze_Aspect_Specifications): Set Has_Delayed_Aspects and
Is_Delayed_Aspect attributes for Aspect_Stable_Properties aspect
specifications.
(Check_Aspect_At_End_Of_Declarations): The syntactic
"expression" for a Stable_Properties aspect specification is not
semantically an expression; it doesn't have a type. Thus, force
T to be empty in this case.
* contracts.adb (Expand_Subprogram_Contract): Add call to new
local procedure,
Expand_Subprogram_Contract.Add_Stable_Property_Contracts, which
generates Postcondition pragmas corresponding to stable property
checks.
Diff:
---
gcc/ada/aspects.adb | 28 ++-
gcc/ada/aspects.ads | 50 ++++--
gcc/ada/contracts.adb | 264 +++++++++++++++++++++++++++-
gcc/ada/sem_ch13.adb | 450 +++++++++++++++++++++++++++++++++++++++++++++++-
gcc/ada/sem_ch13.ads | 6 +
gcc/ada/sem_ch6.adb | 12 +-
gcc/ada/sem_util.adb | 5 +-
gcc/ada/snames.ads-tmpl | 1 +
8 files changed, 777 insertions(+), 39 deletions(-)
diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb
index 37bbcae1d77..91550c82fe7 100644
--- a/gcc/ada/aspects.adb
+++ b/gcc/ada/aspects.adb
@@ -44,6 +44,7 @@ package body Aspects is
Aspect_Discard_Names => True,
Aspect_Independent_Components => True,
Aspect_Iterator_Element => True,
+ Aspect_Stable_Properties => True,
Aspect_Type_Invariant => True,
Aspect_Unchecked_Union => True,
Aspect_Variable_Indexing => True,
@@ -185,7 +186,11 @@ package body Aspects is
-- Find_Aspect --
-----------------
- function Find_Aspect (Id : Entity_Id; A : Aspect_Id) return Node_Id is
+ function Find_Aspect
+ (Id : Entity_Id;
+ A : Aspect_Id;
+ Class_Present : Boolean := False) return Node_Id
+ is
Decl : Node_Id;
Item : Node_Id;
Owner : Entity_Id;
@@ -219,6 +224,7 @@ package body Aspects is
while Present (Item) loop
if Nkind (Item) = N_Aspect_Specification
and then Get_Aspect_Id (Item) = A
+ and then Class_Present = Sinfo.Class_Present (Item)
then
return Item;
end if;
@@ -241,7 +247,9 @@ package body Aspects is
if Permits_Aspect_Specifications (Decl) then
Spec := First (Aspect_Specifications (Decl));
while Present (Spec) loop
- if Get_Aspect_Id (Spec) = A then
+ if Get_Aspect_Id (Spec) = A
+ and then Class_Present = Sinfo.Class_Present (Spec)
+ then
return Spec;
end if;
@@ -260,10 +268,12 @@ package body Aspects is
--------------------------
function Find_Value_Of_Aspect
- (Id : Entity_Id;
- A : Aspect_Id) return Node_Id
+ (Id : Entity_Id;
+ A : Aspect_Id;
+ Class_Present : Boolean := False) return Node_Id
is
- Spec : constant Node_Id := Find_Aspect (Id, A);
+ Spec : constant Node_Id := Find_Aspect (Id, A,
+ Class_Present => Class_Present);
begin
if Present (Spec) then
@@ -296,9 +306,13 @@ package body Aspects is
-- Has_Aspect --
----------------
- function Has_Aspect (Id : Entity_Id; A : Aspect_Id) return Boolean is
+ function Has_Aspect
+ (Id : Entity_Id;
+ A : Aspect_Id;
+ Class_Present : Boolean := False) return Boolean
+ is
begin
- return Present (Find_Aspect (Id, A));
+ return Present (Find_Aspect (Id, A, Class_Present => Class_Present));
end Has_Aspect;
------------------
diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
index 1470efebab9..e16ceb006ee 100644
--- a/gcc/ada/aspects.ads
+++ b/gcc/ada/aspects.ads
@@ -142,6 +142,7 @@ package Aspects is
Aspect_Size,
Aspect_Small,
Aspect_SPARK_Mode, -- GNAT
+ Aspect_Stable_Properties,
Aspect_Static_Predicate,
Aspect_Storage_Pool,
Aspect_Storage_Size,
@@ -237,16 +238,17 @@ package Aspects is
-- The following array indicates aspects that accept 'Class
Class_Aspect_OK : constant array (Aspect_Id) of Boolean :=
- (Aspect_Input => True,
- Aspect_Invariant => True,
- Aspect_Output => True,
- Aspect_Pre => True,
- Aspect_Predicate => True,
- Aspect_Post => True,
- Aspect_Read => True,
- Aspect_Write => True,
- Aspect_Type_Invariant => True,
- others => False);
+ (Aspect_Input => True,
+ Aspect_Invariant => True,
+ Aspect_Output => True,
+ Aspect_Pre => True,
+ Aspect_Predicate => True,
+ Aspect_Post => True,
+ Aspect_Read => True,
+ Aspect_Write => True,
+ Aspect_Stable_Properties => True,
+ Aspect_Type_Invariant => True,
+ others => False);
-- The following array identifies all implementation defined aspects
@@ -427,6 +429,7 @@ package Aspects is
Aspect_Size => Expression,
Aspect_Small => Expression,
Aspect_SPARK_Mode => Optional_Name,
+ Aspect_Stable_Properties => Expression,
Aspect_Static_Predicate => Expression,
Aspect_Storage_Pool => Name,
Aspect_Storage_Size => Expression,
@@ -528,6 +531,7 @@ package Aspects is
Aspect_Size => True,
Aspect_Small => True,
Aspect_SPARK_Mode => False,
+ Aspect_Stable_Properties => False,
Aspect_Static_Predicate => False,
Aspect_Storage_Pool => True,
Aspect_Storage_Size => True,
@@ -704,6 +708,7 @@ package Aspects is
Aspect_Size => Name_Size,
Aspect_Small => Name_Small,
Aspect_SPARK_Mode => Name_SPARK_Mode,
+ Aspect_Stable_Properties => Name_Stable_Properties,
Aspect_Static => Name_Static,
Aspect_Static_Predicate => Name_Static_Predicate,
Aspect_Storage_Pool => Name_Storage_Pool,
@@ -965,6 +970,7 @@ package Aspects is
Aspect_Refined_State => Never_Delay,
Aspect_Relaxed_Initialization => Never_Delay,
Aspect_SPARK_Mode => Never_Delay,
+ Aspect_Stable_Properties => Always_Delay,
Aspect_Static => Never_Delay,
Aspect_Subprogram_Variant => Never_Delay,
Aspect_Synchronization => Never_Delay,
@@ -1094,18 +1100,24 @@ package Aspects is
-- aspect specification list, the routine has no effect. It is assumed that
-- both nodes can support aspects.
- function Find_Aspect (Id : Entity_Id; A : Aspect_Id) return Node_Id;
- -- Find the aspect specification of aspect A associated with entity I.
+ function Find_Aspect (Id : Entity_Id;
+ A : Aspect_Id;
+ Class_Present : Boolean := False) return Node_Id;
+ -- Find the aspect specification of aspect A (or A'Class if Class_Present)
+ -- associated with entity I.
-- Return Empty if Id does not have the requested aspect.
function Find_Value_Of_Aspect
- (Id : Entity_Id;
- A : Aspect_Id) return Node_Id;
- -- Find the value of aspect A associated with entity Id. Return Empty if
- -- Id does not have the requested aspect.
-
- function Has_Aspect (Id : Entity_Id; A : Aspect_Id) return Boolean;
- -- Determine whether entity Id has aspect A
+ (Id : Entity_Id;
+ A : Aspect_Id;
+ Class_Present : Boolean := False) return Node_Id;
+ -- Find the value of aspect A (or A'Class, if Class_Present) associated
+ -- with entity Id. Return Empty if Id does not have the requested aspect.
+
+ function Has_Aspect (Id : Entity_Id;
+ A : Aspect_Id;
+ Class_Present : Boolean := False) return Boolean;
+ -- Determine whether entity Id has aspect A (or A'Class, if Class_Present)
procedure Move_Aspects (From : Node_Id; To : Node_Id);
-- Relocate the aspect specifications of node From to node To. On entry it
diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb
index 3ef607f21d6..1b15d99f02b 100644
--- a/gcc/ada/contracts.adb
+++ b/gcc/ada/contracts.adb
@@ -47,6 +47,7 @@ with Sem_Disp; use Sem_Disp;
with Sem_Prag; use Sem_Prag;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
+with Sinput; use Sinput;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
@@ -1668,6 +1669,12 @@ package body Contracts is
-- function, Result contains the entity of parameter _Result, to be
-- used in the creation of procedure _Postconditions.
+ procedure Add_Stable_Property_Contracts
+ (Subp_Id : Entity_Id; Class_Present : Boolean);
+ -- Augment postcondition contracts to reflect Stable_Property aspect
+ -- (if Class_Present = False) or Stable_Property'Class aspect (if
+ -- Class_Present = True).
+
procedure Append_Enabled_Item (Item : Node_Id; List : in out List_Id);
-- Append a node to a list. If there is no list, create a new one. When
-- the item denotes a pragma, it is added to the list only when it is
@@ -1905,6 +1912,244 @@ package body Contracts is
end loop;
end Add_Invariant_And_Predicate_Checks;
+ -----------------------------------
+ -- Add_Stable_Property_Contracts --
+ -----------------------------------
+
+ procedure Add_Stable_Property_Contracts
+ (Subp_Id : Entity_Id; Class_Present : Boolean)
+ is
+ Loc : constant Source_Ptr := Sloc (Subp_Id);
+
+ procedure Insert_Stable_Property_Check
+ (Formal : Entity_Id; Property_Function : Entity_Id);
+ -- Build the pragma for one check and insert it in the tree.
+
+ function Make_Stable_Property_Condition
+ (Formal : Entity_Id; Property_Function : Entity_Id) return Node_Id;
+ -- Builds tree for "Func (Formal) = Func (Formal)'Old" expression.
+
+ function Stable_Properties
+ (Aspect_Bearer : Entity_Id; Negated : out Boolean)
+ return Subprogram_List;
+ -- If no aspect specified, then returns length-zero result.
+ -- Negated indicates that reserved word NOT was specified.
+
+ ----------------------------------
+ -- Insert_Stable_Property_Check --
+ ----------------------------------
+
+ procedure Insert_Stable_Property_Check
+ (Formal : Entity_Id; Property_Function : Entity_Id) is
+
+ Args : constant List_Id :=
+ New_List
+ (Make_Pragma_Argument_Association
+ (Sloc => Loc,
+ Expression =>
+ Make_Stable_Property_Condition
+ (Formal => Formal,
+ Property_Function => Property_Function)),
+ Make_Pragma_Argument_Association
+ (Sloc => Loc,
+ Expression =>
+ Make_String_Literal
+ (Sloc => Loc,
+ Strval =>
+ "failed stable property check at "
+ & Build_Location_String (Loc)
+ & " for parameter "
+ & To_String (Fully_Qualified_Name_String
+ (Formal, Append_NUL => False))
+ & " and property function "
+ & To_String (Fully_Qualified_Name_String
+ (Property_Function, Append_NUL => False))
+ )));
+
+ Prag : constant Node_Id :=
+ Make_Pragma (Loc,
+ Pragma_Identifier =>
+ Make_Identifier (Loc, Name_Postcondition),
+ Pragma_Argument_Associations => Args,
+ Class_Present => Class_Present);
+
+ Subp_Decl : Node_Id := Subp_Id;
+ begin
+ -- Enclosing_Declaration may return, for example,
+ -- a N_Procedure_Specification node. Cope with this.
+ loop
+ Subp_Decl := Enclosing_Declaration (Subp_Decl);
+ exit when Is_Declaration (Subp_Decl);
+ Subp_Decl := Parent (Subp_Decl);
+ pragma Assert (Present (Subp_Decl));
+ end loop;
+
+ Insert_After_And_Analyze (Subp_Decl, Prag);
+ end Insert_Stable_Property_Check;
+
+ ------------------------------------
+ -- Make_Stable_Property_Condition --
+ ------------------------------------
+
+ function Make_Stable_Property_Condition
+ (Formal : Entity_Id; Property_Function : Entity_Id) return Node_Id
+ is
+ function Call_Property_Function return Node_Id is
+ (Make_Function_Call
+ (Loc,
+ Name =>
+ New_Occurrence_Of (Property_Function, Loc),
+ Parameter_Associations =>
+ New_List (New_Occurrence_Of (Formal, Loc))));
+ begin
+ return Make_Op_Eq
+ (Loc,
+ Call_Property_Function,
+ Make_Attribute_Reference
+ (Loc,
+ Prefix => Call_Property_Function,
+ Attribute_Name => Name_Old));
+ end Make_Stable_Property_Condition;
+
+ -----------------------
+ -- Stable_Properties --
+ -----------------------
+
+ function Stable_Properties
+ (Aspect_Bearer : Entity_Id; Negated : out Boolean)
+ return Subprogram_List
+ is
+ Aspect_Spec : Node_Id :=
+ Find_Value_Of_Aspect
+ (Aspect_Bearer, Aspect_Stable_Properties,
+ Class_Present => Class_Present);
+ begin
+ -- ??? For a derived type, we wish Find_Value_Of_Aspect
+ -- somehow knew that this aspect is not inherited.
+ -- But it doesn't, so we cope with that here.
+ --
+ -- There are probably issues here with inheritance from
+ -- interface types, where just looking for the one parent type
+ -- isn't enough. But this is far from the only work needed for
+ -- Stable_Properties'Class for interface types.
+
+ if Is_Derived_Type (Aspect_Bearer) then
+ declare
+ Parent_Type : constant Entity_Id :=
+ Etype (Base_Type (Aspect_Bearer));
+ begin
+ if Aspect_Spec =
+ Find_Value_Of_Aspect
+ (Parent_Type, Aspect_Stable_Properties,
+ Class_Present => Class_Present)
+ then
+ -- prevent inheritance
+ Aspect_Spec := Empty;
+ end if;
+ end;
+ end if;
+
+ if No (Aspect_Spec) then
+ Negated := Aspect_Bearer = Subp_Id;
+ -- This is a little bit subtle.
+ -- We need to assign True in the Subp_Id case in order to
+ -- distinguish between no aspect spec at all vs. an
+ -- explicitly specified "with S_P => []" empty list.
+ -- In both cases Stable_Properties will return a length-0
+ -- array, but the two cases are not equivalent.
+ -- Very roughly speaking the lack of an S_P aspect spec for
+ -- a subprogram would be equivalent to something like
+ -- "with S_P => [not]", where we apply the "not" modifier to
+ -- an empty set of subprograms, if such a construct existed.
+ -- We could just assign True here, but it seems untidy to
+ -- return True in the case of an aspect spec for a type
+ -- (since negation is only allowed for subp S_P aspects).
+
+ return (1 .. 0 => <>);
+ else
+ return Parse_Aspect_Stable_Properties
+ (Aspect_Spec, Negated => Negated);
+ end if;
+ end Stable_Properties;
+
+ Formal : Entity_Id := First_Formal (Subp_Id);
+ Type_Of_Formal : Entity_Id;
+
+ Subp_Properties_Negated : Boolean;
+ Subp_Properties : constant Subprogram_List :=
+ Stable_Properties (Subp_Id, Subp_Properties_Negated);
+
+ -- start of processing for Add_Stable_Property_Contracts
+
+ begin
+ if not (Is_Primitive (Subp_Id) and then Comes_From_Source (Subp_Id))
+ then
+ return;
+ end if;
+
+ while Present (Formal) loop
+ Type_Of_Formal := Base_Type (Etype (Formal));
+
+ if not Subp_Properties_Negated then
+
+ for SPF_Id of Subp_Properties loop
+ if Type_Of_Formal = Base_Type (Etype (First_Formal (SPF_Id)))
+ and then Scope (Type_Of_Formal) = Scope (Subp_Id)
+ then
+ -- ??? Need to filter out checks for SPFs that are
+ -- mentioned explicitly in the postcondition of
+ -- Subp_Id.
+
+ Insert_Stable_Property_Check
+ (Formal => Formal, Property_Function => SPF_Id);
+ end if;
+ end loop;
+
+ elsif Scope (Type_Of_Formal) = Scope (Subp_Id) then
+ declare
+ Ignored : Boolean range False .. False;
+
+ Typ_Property_Funcs : constant Subprogram_List :=
+ Stable_Properties (Type_Of_Formal, Negated => Ignored);
+
+ function Excluded_By_Aspect_Spec_Of_Subp
+ (SPF_Id : Entity_Id) return Boolean;
+ -- Examine Subp_Properties to determine whether SPF should
+ -- be excluded.
+
+ -------------------------------------
+ -- Excluded_By_Aspect_Spec_Of_Subp --
+ -------------------------------------
+
+ function Excluded_By_Aspect_Spec_Of_Subp
+ (SPF_Id : Entity_Id) return Boolean is
+ begin
+ pragma Assert (Subp_Properties_Negated);
+ -- Look through renames for equality test here ???
+ return (for some F of Subp_Properties => F = SPF_Id);
+ end Excluded_By_Aspect_Spec_Of_Subp;
+
+ -- Look through renames for equality test here ???
+ Subp_Is_Stable_Property_Function : constant Boolean :=
+ (for some F of Typ_Property_Funcs => F = Subp_Id);
+ begin
+ if not Subp_Is_Stable_Property_Function then
+ for SPF_Id of Typ_Property_Funcs loop
+ if not Excluded_By_Aspect_Spec_Of_Subp (SPF_Id) then
+ -- ??? Need to filter out checks for SPFs that are
+ -- mentioned explicitly in the postcondition of
+ -- Subp_Id.
+ Insert_Stable_Property_Check
+ (Formal => Formal, Property_Function => SPF_Id);
+ end if;
+ end loop;
+ end if;
+ end;
+ end if;
+ Next_Formal (Formal);
+ end loop;
+ end Add_Stable_Property_Contracts;
+
-------------------------
-- Append_Enabled_Item --
-------------------------
@@ -2793,30 +3038,39 @@ package body Contracts is
-- Routine _Postconditions holds all contract assertions that must be
-- verified on exit from the related subprogram.
- -- Step 1: Handle all preconditions. This action must come before the
+ -- Step 1: augment contracts list with postconditions associated with
+ -- Stable_Properties and Stable_Properties'Class aspects. This must
+ -- precede Process_Postconditions.
+
+ for Class_Present in Boolean loop
+ Add_Stable_Property_Contracts
+ (Subp_Id, Class_Present => Class_Present);
+ end loop;
+
+ -- Step 2: Handle all preconditions. This action must come before the
-- processing of pragma Contract_Cases because the pragma prepends items
-- to the body declarations.
Process_Preconditions;
- -- Step 2: Handle all postconditions. This action must come before the
+ -- Step 3: Handle all postconditions. This action must come before the
-- processing of pragma Contract_Cases because the pragma appends items
-- to list Stmts.
Process_Postconditions (Stmts);
- -- Step 3: Handle pragma Contract_Cases. This action must come before
+ -- Step 4: Handle pragma Contract_Cases. This action must come before
-- the processing of invariants and predicates because those append
-- items to list Stmts.
Process_Contract_Cases (Stmts);
- -- Step 4: Apply invariant and predicate checks on a function result and
+ -- Step 5: Apply invariant and predicate checks on a function result and
-- all formals. The resulting checks are accumulated in list Stmts.
Add_Invariant_And_Predicate_Checks (Subp_Id, Stmts, Result);
- -- Step 5: Construct procedure _Postconditions
+ -- Step 6: Construct procedure _Postconditions
Build_Postconditions_Procedure (Subp_Id, Stmts, Result);
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index b1c8b077399..ba7f5b8e0e8 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -54,7 +54,6 @@ with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
with Sem_Dim; use Sem_Dim;
-with Sem_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval;
with Sem_Prag; use Sem_Prag;
with Sem_Res; use Sem_Res;
@@ -252,6 +251,18 @@ package body Sem_Ch13 is
-- Resolve each one of the operations specified in the specification of
-- Aspect_Aggregate.
+ procedure Validate_Aspect_Stable_Properties
+ (E : Entity_Id; N : Node_Id; Class_Present : Boolean);
+ -- Check legality of functions given in the Ada 202x Stable_Properties
+ -- (or Stable_Properties'Class) aspect.
+
+ procedure Resolve_Aspect_Stable_Properties
+ (Typ_Or_Subp : Entity_Id;
+ Expr : Node_Id;
+ Class_Present : Boolean);
+ -- Resolve each one of the functions specified in the specification of
+ -- aspect Stable_Properties (or Stable_Properties'Class).
+
procedure Resolve_Iterable_Operation
(N : Node_Id;
Cursor : Entity_Id;
@@ -2956,6 +2967,18 @@ package body Sem_Ch13 is
end if;
end case;
+ if Delay_Required
+
+ and then A_Id = Aspect_Stable_Properties
+ -- ??? It seems like we should do this for all aspects, not
+ -- just Stable_Properties, but that causes as-yet-undiagnosed
+ -- regressions.
+
+ then
+ Set_Has_Delayed_Aspects (E);
+ Set_Is_Delayed_Aspect (Aspect);
+ end if;
+
-- Check 13.1(9.2/5): A representation aspect of a subtype or type
-- shall not be specified (whether by a representation item or an
-- aspect_specification) before the type is completely defined
@@ -4198,6 +4221,12 @@ package body Sem_Ch13 is
Record_Rep_Item (E, Aspect);
goto Continue;
+ when Aspect_Stable_Properties =>
+ Validate_Aspect_Stable_Properties
+ (E, Expr, Class_Present => Class_Present (Aspect));
+ Record_Rep_Item (E, Aspect);
+ goto Continue;
+
when Aspect_Integer_Literal
| Aspect_Real_Literal
| Aspect_String_Literal
@@ -10490,12 +10519,14 @@ package body Sem_Ch13 is
-- Expression from call to Check_Aspect_At_Freeze_Point.
T : constant Entity_Id :=
- (if Present (Freeze_Expr)
+ (if Present (Freeze_Expr) and (A_Id /= Aspect_Stable_Properties)
then Etype (Original_Node (Freeze_Expr))
else Empty);
-- Type required for preanalyze call. We use the original expression to
-- get the proper type, to prevent cascaded errors when the expression
- -- is constant-folded.
+ -- is constant-folded. For Stable_Properties, the aspect value is
+ -- not semantically an expression (although it is syntactically);
+ -- in particular, it has no type.
Err : Boolean;
-- Set False if error
@@ -10902,7 +10933,13 @@ package body Sem_Ch13 is
return;
when Aspect_Aggregate =>
- Resolve_Aspect_Aggregate (Entity (ASN), Expr);
+ Resolve_Aspect_Aggregate (Entity (ASN), Expression (ASN));
+ return;
+
+ when Aspect_Stable_Properties =>
+ Resolve_Aspect_Stable_Properties
+ (Entity (ASN), Expression (ASN),
+ Class_Present => Class_Present (ASN));
return;
-- Invariant/Predicate take boolean expressions
@@ -14894,6 +14931,10 @@ package body Sem_Ch13 is
when Aspect_Aggregate =>
Resolve_Aspect_Aggregate (Entity (ASN), Expr);
+ when Aspect_Stable_Properties =>
+ Resolve_Aspect_Stable_Properties
+ (Entity (ASN), Expr, Class_Present (ASN));
+
-- For now we only deal with aspects that do not generate
-- subprograms, or that may mention current instances of
-- types. These will require special handling (???TBD).
@@ -15032,6 +15073,60 @@ package body Sem_Ch13 is
end loop;
end Parse_Aspect_Aggregate;
+ ------------------------------------
+ -- Parse_Aspect_Stable_Properties --
+ ------------------------------------
+
+ function Parse_Aspect_Stable_Properties
+ (Aspect_Spec : Node_Id; Negated : out Boolean) return Subprogram_List
+ is
+ L : List_Id;
+ Id : Node_Id;
+
+ function Extract_Entity (Expr : Node_Id) return Entity_Id;
+ -- Given an element of a Stable_Properties aspect spec,
+ -- return the associated entity.
+ -- This function updates the Negated flag as a side-effect.
+
+ function Extract_Entity (Expr : Node_Id) return Entity_Id is
+ Name : Node_Id := Expr;
+ begin
+ if Nkind (Expr) = N_Op_Not then
+ Negated := True;
+ Name := Right_Opnd (Expr);
+ end if;
+ if Nkind (Name) in N_Has_Entity then
+ return Entity (Name);
+ else
+ return Empty;
+ end if;
+ end Extract_Entity;
+ begin
+ Negated := False;
+
+ if Nkind (Aspect_Spec) /= N_Aggregate then
+ return (1 => Extract_Entity (Aspect_Spec));
+ else
+ L := Expressions (Aspect_Spec);
+ Id := First (L);
+
+ return Result : Subprogram_List (1 .. List_Length (L)) do
+ for I in Result'Range loop
+ Result (I) := Extract_Entity (Id);
+
+ if not Present (Result (I)) then
+ pragma Assert (Serious_Errors_Detected > 0);
+ goto Ignore_Aspect;
+ end if;
+
+ Next (Id);
+ end loop;
+ end return;
+ end if;
+
+ <<Ignore_Aspect>> return (1 .. 0 => <>);
+ end Parse_Aspect_Stable_Properties;
+
-------------------------------
-- Validate_Aspect_Aggregate --
-------------------------------
@@ -15078,6 +15173,135 @@ package body Sem_Ch13 is
end if;
end Validate_Aspect_Aggregate;
+ -------------------------------
+ -- Validate_Aspect_Stable_Properties --
+ -------------------------------
+
+ procedure Validate_Aspect_Stable_Properties
+ (E : Entity_Id; N : Node_Id; Class_Present : Boolean)
+ is
+ Is_Aspect_Of_Type : constant Boolean := Is_Type (E);
+
+ type Permission is (Forbidden, Optional, Required);
+ Modifier_Permission : Permission :=
+ (if Is_Aspect_Of_Type then Forbidden else Optional);
+ Modifier_Error_Called : Boolean := False;
+
+ procedure Check_Property_Function_Arg (PF_Arg : Node_Id);
+ -- Check syntax of a property function argument
+
+ ----------------------------------
+ -- Check_Property_Function_Arg --
+ ----------------------------------
+
+ procedure Check_Property_Function_Arg (PF_Arg : Node_Id) is
+ procedure Modifier_Error;
+ -- Generate message about bad "not" modifier if no message already
+ -- generated. Errors include specifying "not" for an aspect of
+ -- of a type and specifying "not" for some but not all of the
+ -- names in a list.
+
+ --------------------
+ -- Modifier_Error --
+ --------------------
+
+ procedure Modifier_Error is
+ begin
+ if Modifier_Error_Called then
+ return; -- error message already generated
+ end if;
+
+ Modifier_Error_Called := True;
+
+ if Is_Aspect_Of_Type then
+ Error_Msg_N
+ ("NOT modifier not allowed for Stable_Properties aspect"
+ & " of a type", PF_Arg);
+ else
+ Error_Msg_N ("Mixed use of NOT modifiers", PF_Arg);
+ end if;
+ end Modifier_Error;
+
+ PF_Name : Node_Id := PF_Arg;
+
+ -- Start of processing for Check_Property_Function_Arg
+ begin
+ if Nkind (PF_Arg) = N_Op_Not then
+ PF_Name := Right_Opnd (PF_Arg);
+
+ case Modifier_Permission is
+ when Forbidden =>
+ Modifier_Error;
+ when Optional =>
+ Modifier_Permission := Required;
+ when Required =>
+ null;
+ end case;
+ else
+ case Modifier_Permission is
+ when Forbidden =>
+ null;
+ when Optional =>
+ Modifier_Permission := Forbidden;
+ when Required =>
+ Modifier_Error;
+ end case;
+ end if;
+
+ if Nkind (PF_Name) not in
+ N_Identifier | N_Operator_Symbol | N_Selected_Component
+ then
+ Error_Msg_N ("Bad property function name", PF_Name);
+ end if;
+ end Check_Property_Function_Arg;
+
+ begin
+ if Ada_Version < Ada_2020 then
+ Error_Msg_N ("Aspect Stable_Properties is an Ada_2020 feature", N);
+ end if;
+
+ if (not Is_Aspect_Of_Type) and then (not Is_Subprogram (E)) then
+ Error_Msg_N ("Stable_Properties aspect can only be specified for "
+ & "a type or a subprogram", N);
+ elsif Class_Present then
+ if Is_Aspect_Of_Type then
+ if not Is_Tagged_Type (E) then
+ Error_Msg_N
+ ("Stable_Properties'Class aspect cannot be specified for "
+ & "an untagged type", N);
+ end if;
+ else
+ if not Is_Dispatching_Operation (E) then
+ Error_Msg_N
+ ("Stable_Properties'Class aspect cannot be specified for "
+ & "a subprogram that is not a primitive subprogram "
+ & "of a tagged type", N);
+ end if;
+ end if;
+ end if;
+
+ if Nkind (N) = N_Aggregate then
+ if Present (Component_Associations (N))
+ or else Null_Record_Present (N)
+ or else not Present (Expressions (N))
+ then
+ Error_Msg_N ("Bad Stable_Properties aspect specification", N);
+ return;
+ end if;
+
+ declare
+ PF_Arg : Node_Id := First (Expressions (N));
+ begin
+ while Present (PF_Arg) loop
+ Check_Property_Function_Arg (PF_Arg);
+ PF_Arg := Next (PF_Arg);
+ end loop;
+ end;
+ else
+ Check_Property_Function_Arg (N);
+ end if;
+ end Validate_Aspect_Stable_Properties;
+
--------------------------------
-- Resolve_Iterable_Operation --
--------------------------------
@@ -15437,6 +15661,224 @@ package body Sem_Ch13 is
end loop;
end Resolve_Aspect_Aggregate;
+ --------------------------------------
+ -- Resolve_Aspect_Stable_Properties --
+ --------------------------------------
+
+ procedure Resolve_Aspect_Stable_Properties
+ (Typ_Or_Subp : Entity_Id; Expr : Node_Id; Class_Present : Boolean)
+ is
+ Is_Aspect_Of_Type : constant Boolean := Is_Type (Typ_Or_Subp);
+
+ Singleton : constant Boolean := Nkind (Expr) /= N_Aggregate;
+ Subp_Name : Node_Id := (if Singleton
+ then Expr
+ else First (Expressions (Expr)));
+ Has_Not : Boolean;
+ begin
+ if Is_Aspect_Of_Type
+ and then Has_Private_Declaration (Typ_Or_Subp)
+ and then not Is_Private_Type (Typ_Or_Subp)
+ then
+ Error_Msg_N
+ ("Stable_Properties aspect cannot be specified " &
+ "for the completion of a private type", Typ_Or_Subp);
+ end if;
+
+ -- Analogous checks that the aspect is not specified for a completion
+ -- in the subprogram case are not performed here because they are not
+ -- specific to this particular aspect. Right ???
+
+ loop
+ Has_Not := Nkind (Subp_Name) = N_Op_Not;
+ if Has_Not then
+ Set_Analyzed (Subp_Name); -- ???
+ Subp_Name := Right_Opnd (Subp_Name);
+ end if;
+
+ if No (Etype (Subp_Name)) then
+ Analyze (Subp_Name);
+ end if;
+
+ declare
+ Subp : Entity_Id := Empty;
+
+ I : Interp_Index;
+ It : Interp;
+
+ function Is_Property_Function (E : Entity_Id) return Boolean;
+ -- Implements RM 7.3.4 definition of "property function".
+
+ function Is_Property_Function (E : Entity_Id) return Boolean is
+ begin
+ if Ekind (E) not in E_Function | E_Operator
+ or else Number_Formals (E) /= 1
+ then
+ return False;
+ end if;
+
+ declare
+ Param_Type : constant Entity_Id :=
+ Base_Type (Etype (First_Formal (E)));
+
+ function Matches_Param_Type (Typ : Entity_Id)
+ return Boolean is
+ ((Base_Type (Typ) = Param_Type)
+ or else
+ (Is_Class_Wide_Type (Param_Type)
+ and then Is_Ancestor (Root_Type (Param_Type),
+ Base_Type (Typ))));
+ begin
+ if Is_Aspect_Of_Type then
+ if Matches_Param_Type (Typ_Or_Subp) then
+ return True;
+ end if;
+ elsif Is_Primitive (Typ_Or_Subp) then
+ declare
+ Formal : Entity_Id := First_Formal (Typ_Or_Subp);
+ begin
+ while Present (Formal) loop
+ if Matches_Param_Type (Etype (Formal)) then
+
+ -- Test whether Typ_Or_Subp (which is a subp
+ -- in this case) is primitive op of the type
+ -- of this parameter.
+ if Scope (Typ_Or_Subp) = Scope (Param_Type) then
+ return True;
+ end if;
+ end if;
+ Next_Formal (Formal);
+ end loop;
+ end;
+ end if;
+ end;
+
+ return False;
+ end Is_Property_Function;
+ begin
+ if not Is_Overloaded (Subp_Name) then
+ Subp := Entity (Subp_Name);
+ if not Is_Property_Function (Subp) then
+ Error_Msg_NE ("improper property function for&",
+ Subp_Name, Typ_Or_Subp);
+ return;
+ end if;
+ else
+ Set_Entity (Subp_Name, Empty);
+ Get_First_Interp (Subp_Name, I, It);
+ while Present (It.Nam) loop
+ if Is_Property_Function (It.Nam) then
+ if Present (Subp) then
+ Error_Msg_NE
+ ("ambiguous property function name for&",
+ Subp_Name, Typ_Or_Subp);
+ return;
+ end if;
+
+ Subp := It.Nam;
+ Set_Is_Overloaded (Subp_Name, False);
+ Set_Entity (Subp_Name, Subp);
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ if No (Subp) then
+ Error_Msg_NE ("improper property function for&",
+ Subp_Name, Typ_Or_Subp);
+ return;
+ end if;
+ end if;
+
+ -- perform legality (as opposed to name resolution) Subp checks
+
+ if Is_Limited_Type (Etype (Subp)) then
+ Error_Msg_NE
+ ("result type of property function for& is limited",
+ Subp_Name, Typ_Or_Subp);
+ end if;
+
+ if Ekind (First_Formal (Subp)) /= E_In_Parameter then
+ Error_Msg_NE
+ ("mode of parameter of property function for& is not IN",
+ Subp_Name, Typ_Or_Subp);
+ end if;
+
+ if Is_Class_Wide_Type (Etype (First_Formal (Subp))) then
+ if not Covers (Etype (First_Formal (Subp)), Typ_Or_Subp) then
+ Error_Msg_NE
+ ("class-wide parameter type of property function " &
+ "for& does not cover the type",
+ Subp_Name, Typ_Or_Subp);
+
+ -- ??? This test is slightly stricter than 7.3.4(12/5);
+ -- some legal corner cases may be incorrectly rejected.
+ elsif Scope (Subp) /= Scope (Etype (First_Formal (Subp)))
+ then
+ Error_Msg_NE
+ ("property function for& not declared in same scope " &
+ "as parameter type",
+ Subp_Name, Typ_Or_Subp);
+ end if;
+ elsif Is_Aspect_Of_Type and then
+ Scope (Subp) /= Scope (Typ_Or_Subp) and then
+ Scope (Subp) /= Standard_Standard -- e.g., derived type's "abs"
+ then
+ Error_Msg_NE
+ ("property function for& " &
+ "not a primitive function of the type",
+ Subp_Name, Typ_Or_Subp);
+ end if;
+
+ if Has_Not then
+ -- check that Subp was mentioned in param type's aspect spec
+ declare
+ Param_Type : constant Entity_Id :=
+ Base_Type (Etype (First_Formal (Subp)));
+ Aspect_Spec : constant Node_Id :=
+ Find_Value_Of_Aspect
+ (Param_Type, Aspect_Stable_Properties,
+ Class_Present => Class_Present);
+ Found : Boolean := False;
+ begin
+ if Present (Aspect_Spec) then
+ declare
+ Ignored : Boolean;
+ SPF_List : constant Subprogram_List :=
+ Parse_Aspect_Stable_Properties
+ (Aspect_Spec, Negated => Ignored);
+ begin
+ Found := (for some E of SPF_List => E = Subp);
+ -- look through renamings ???
+ end;
+ end if;
+ if not Found then
+ declare
+ CW_Modifier : constant String :=
+ (if Class_Present then "class-wide " else "");
+ begin
+ Error_Msg_NE
+ (CW_Modifier
+ & "property function for& mentioned after NOT "
+ & "but not a "
+ & CW_Modifier
+ & "stable property function of its parameter type",
+ Subp_Name, Typ_Or_Subp);
+ end;
+ end if;
+ end;
+ end if;
+ end;
+
+ exit when Singleton;
+ Subp_Name :=
+ Next ((if Has_Not then Parent (Subp_Name) else Subp_Name));
+ exit when No (Subp_Name);
+ end loop;
+
+ Set_Analyzed (Expr);
+ end Resolve_Aspect_Stable_Properties;
+
----------------
-- Set_Biased --
----------------
diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads
index 7d9f38d87e9..389bb414781 100644
--- a/gcc/ada/sem_ch13.ads
+++ b/gcc/ada/sem_ch13.ads
@@ -25,6 +25,7 @@
with Table;
with Types; use Types;
+with Sem_Disp; use Sem_Disp;
with Uintp; use Uintp;
package Sem_Ch13 is
@@ -147,6 +148,11 @@ package Sem_Ch13 is
-- used to verify the structure of the aspect, and resolve and expand an
-- aggregate for a container type that carries the aspect.
+ function Parse_Aspect_Stable_Properties
+ (Aspect_Spec : Node_Id; Negated : out Boolean) return Subprogram_List;
+ -- Utility to unpack the subprograms in a Stable_Properties list;
+ -- in the case of the aspect of a type, Negated will always be False.
+
function Rep_Item_Too_Early (T : Entity_Id; N : Node_Id) return Boolean;
-- Called at start of processing a representation clause/pragma. Used to
-- check that the representation item is not being applied to an incomplete
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 3d397a1fefe..35e13a5750a 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -2109,12 +2109,18 @@ package body Sem_Ch6 is
-- is just a string, as in (conjunction = "or"). In these cases the parser
-- generates this node, and the semantics does the disambiguation. Other
-- such case are actuals in an instantiation, the generic unit in an
- -- instantiation, and pragma arguments.
+ -- instantiation, pragma arguments, and aspect specifications.
procedure Analyze_Operator_Symbol (N : Node_Id) is
Par : constant Node_Id := Parent (N);
+ Maybe_Aspect_Spec : Node_Id := Par;
begin
+ if Nkind (Maybe_Aspect_Spec) /= N_Aspect_Specification then
+ -- deal with N_Aggregate nodes
+ Maybe_Aspect_Spec := Parent (Maybe_Aspect_Spec);
+ end if;
+
if (Nkind (Par) = N_Function_Call and then N = Name (Par))
or else Nkind (Par) = N_Function_Instantiation
or else (Nkind (Par) = N_Indexed_Component and then N = Prefix (Par))
@@ -2123,6 +2129,10 @@ package body Sem_Ch6 is
or else Nkind (Par) = N_Subprogram_Renaming_Declaration
or else (Nkind (Par) = N_Attribute_Reference
and then Attribute_Name (Par) /= Name_Value)
+ or else (Nkind (Maybe_Aspect_Spec) = N_Aspect_Specification
+ and then Get_Aspect_Id (Maybe_Aspect_Spec)
+ -- include other aspects here ???
+ in Aspect_Stable_Properties | Aspect_Aggregate)
then
Find_Direct_Name (N);
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 2a4874df677..958e55aa06a 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -12729,12 +12729,11 @@ package body Sem_Util is
----------------------------------
function Has_Non_Trivial_Precondition (Subp : Entity_Id) return Boolean is
- Pre : constant Node_Id := Find_Aspect (Subp, Aspect_Pre);
-
+ Pre : constant Node_Id := Find_Aspect (Subp, Aspect_Pre,
+ Class_Present => True);
begin
return
Present (Pre)
- and then Class_Present (Pre)
and then not Is_Entity_Name (Expression (Pre));
end Has_Non_Trivial_Precondition;
diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
index 51fc283b056..d08ab538710 100644
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -147,6 +147,7 @@ package Snames is
Name_Integer_Literal : constant Name_Id := N + $;
Name_Real_Literal : constant Name_Id := N + $;
Name_Relaxed_Initialization : constant Name_Id := N + $;
+ Name_Stable_Properties : constant Name_Id := N + $;
Name_Static_Predicate : constant Name_Id := N + $;
Name_String_Literal : constant Name_Id := N + $;
Name_Synchronization : constant Name_Id := N + $;
More information about the Gcc-cvs
mailing list