From 23e3e22105723fde2a9161757611544f180ba805 Mon Sep 17 00:00:00 2001 From: Steve Baird Date: Wed, 21 Oct 2020 16:57:04 -0700 Subject: [PATCH] [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. --- 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; + + <> 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 + $; -- 2.30.2