diff options
Diffstat (limited to 'gcc/ada/sem_util.adb')
| -rw-r--r-- | gcc/ada/sem_util.adb | 261 |
1 files changed, 87 insertions, 174 deletions
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 816fb45..98e68779 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -2212,180 +2212,6 @@ package body Sem_Util is return Empty; end Build_Actual_Subtype_Of_Component; - --------------------------------- - -- Build_Class_Wide_Clone_Body -- - --------------------------------- - - procedure Build_Class_Wide_Clone_Body - (Spec_Id : Entity_Id; - Bod : Node_Id) - is - Loc : constant Source_Ptr := Sloc (Bod); - Clone_Id : constant Entity_Id := Class_Wide_Clone (Spec_Id); - Clone_Body : Node_Id; - Assoc_List : constant Elist_Id := New_Elmt_List; - - begin - -- The declaration of the class-wide clone was created when the - -- corresponding class-wide condition was analyzed. - - -- The body of the original condition may contain references to - -- the formals of Spec_Id. In the body of the class-wide clone, - -- these must be replaced with the corresponding formals of - -- the clone. - - declare - Spec_Formal_Id : Entity_Id := First_Formal (Spec_Id); - Clone_Formal_Id : Entity_Id := First_Formal (Clone_Id); - begin - while Present (Spec_Formal_Id) loop - Append_Elmt (Spec_Formal_Id, Assoc_List); - Append_Elmt (Clone_Formal_Id, Assoc_List); - - Next_Formal (Spec_Formal_Id); - Next_Formal (Clone_Formal_Id); - end loop; - end; - - Clone_Body := - Make_Subprogram_Body (Loc, - Specification => - Copy_Subprogram_Spec (Parent (Clone_Id)), - Declarations => Declarations (Bod), - Handled_Statement_Sequence => - New_Copy_Tree (Handled_Statement_Sequence (Bod), - Map => Assoc_List)); - - -- The new operation is internal and overriding indicators do not apply - -- (the original primitive may have carried one). - - Set_Must_Override (Specification (Clone_Body), False); - - -- If the subprogram body is the proper body of a stub, insert the - -- subprogram after the stub, i.e. the same declarative region as - -- the original sugprogram. - - if Nkind (Parent (Bod)) = N_Subunit then - Insert_After (Corresponding_Stub (Parent (Bod)), Clone_Body); - - else - Insert_Before (Bod, Clone_Body); - end if; - - Analyze (Clone_Body); - end Build_Class_Wide_Clone_Body; - - --------------------------------- - -- Build_Class_Wide_Clone_Call -- - --------------------------------- - - function Build_Class_Wide_Clone_Call - (Loc : Source_Ptr; - Decls : List_Id; - Spec_Id : Entity_Id; - Spec : Node_Id) return Node_Id - is - Clone_Id : constant Entity_Id := Class_Wide_Clone (Spec_Id); - Par_Type : constant Entity_Id := Find_Dispatching_Type (Spec_Id); - - Actuals : List_Id; - Call : Node_Id; - Formal : Entity_Id; - New_Body : Node_Id; - New_F_Spec : Entity_Id; - New_Formal : Entity_Id; - - begin - Actuals := Empty_List; - Formal := First_Formal (Spec_Id); - New_F_Spec := First (Parameter_Specifications (Spec)); - - -- Build parameter association for call to class-wide clone. - - while Present (Formal) loop - New_Formal := Defining_Identifier (New_F_Spec); - - -- If controlling argument and operation is inherited, add conversion - -- to parent type for the call. - - if Etype (Formal) = Par_Type - and then not Is_Empty_List (Decls) - then - Append_To (Actuals, - Make_Type_Conversion (Loc, - New_Occurrence_Of (Par_Type, Loc), - New_Occurrence_Of (New_Formal, Loc))); - - else - Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc)); - end if; - - Next_Formal (Formal); - Next (New_F_Spec); - end loop; - - if Ekind (Spec_Id) = E_Procedure then - Call := - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (Clone_Id, Loc), - Parameter_Associations => Actuals); - else - Call := - Make_Simple_Return_Statement (Loc, - Expression => - Make_Function_Call (Loc, - Name => New_Occurrence_Of (Clone_Id, Loc), - Parameter_Associations => Actuals)); - end if; - - New_Body := - Make_Subprogram_Body (Loc, - Specification => - Copy_Subprogram_Spec (Spec), - Declarations => Decls, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Call), - End_Label => Make_Identifier (Loc, Chars (Spec_Id)))); - - return New_Body; - end Build_Class_Wide_Clone_Call; - - --------------------------------- - -- Build_Class_Wide_Clone_Decl -- - --------------------------------- - - procedure Build_Class_Wide_Clone_Decl (Spec_Id : Entity_Id) is - Loc : constant Source_Ptr := Sloc (Spec_Id); - Clone_Id : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_External_Name (Chars (Spec_Id), Suffix => "CL")); - - Decl : Node_Id; - Spec : Node_Id; - - begin - Spec := Copy_Subprogram_Spec (Parent (Spec_Id)); - Set_Must_Override (Spec, False); - Set_Must_Not_Override (Spec, False); - Set_Defining_Unit_Name (Spec, Clone_Id); - - Decl := Make_Subprogram_Declaration (Loc, Spec); - Append (Decl, List_Containing (Unit_Declaration_Node (Spec_Id))); - - -- Link clone to original subprogram, for use when building body and - -- wrapper call to inherited operation. - - Set_Class_Wide_Clone (Spec_Id, Clone_Id); - - -- Inherit debug info flag from Spec_Id to Clone_Id to allow debugging - -- of the class-wide clone subprogram. - - if Needs_Debug_Info (Spec_Id) then - Set_Debug_Info_Needed (Clone_Id); - end if; - end Build_Class_Wide_Clone_Decl; - ----------------------------- -- Build_Component_Subtype -- ----------------------------- @@ -5878,6 +5704,30 @@ package body Sem_Util is end if; end Choice_List; + --------------------- + -- Class_Condition -- + --------------------- + + function Class_Condition + (Kind : Condition_Kind; + Subp : Entity_Id) return Node_Id is + + begin + case Kind is + when Class_Postcondition => + return Class_Postconditions (Subp); + + when Class_Precondition => + return Class_Preconditions (Subp); + + when Ignored_Class_Postcondition => + return Ignored_Class_Postconditions (Subp); + + when Ignored_Class_Precondition => + return Ignored_Class_Preconditions (Subp); + end case; + end Class_Condition; + ------------------------- -- Collect_Body_States -- ------------------------- @@ -22789,6 +22639,61 @@ package body Sem_Util is return Result; end Might_Raise; + ---------------------------------------- + -- Nearest_Class_Condition_Subprogram -- + ---------------------------------------- + + function Nearest_Class_Condition_Subprogram + (Kind : Condition_Kind; + Spec_Id : Entity_Id) return Entity_Id + is + Subp_Id : constant Entity_Id := Ultimate_Alias (Spec_Id); + + begin + -- Prevent cascaded errors + + if not Is_Dispatching_Operation (Subp_Id) then + return Empty; + + -- No need to search if this subprogram has class-wide postconditions + + elsif Present (Class_Condition (Kind, Subp_Id)) then + return Subp_Id; + end if; + + -- Process the contracts of inherited subprograms, looking for + -- class-wide pre/postconditions. + + declare + Subps : constant Subprogram_List := Inherited_Subprograms (Subp_Id); + Subp_Id : Entity_Id; + + begin + for Index in Subps'Range loop + Subp_Id := Subps (Index); + + if Present (Alias (Subp_Id)) then + Subp_Id := Ultimate_Alias (Subp_Id); + end if; + + -- Wrappers of class-wide pre/postconditions reference the + -- parent primitive that has the inherited contract. + + if Is_Wrapper (Subp_Id) + and then Present (LSP_Subprogram (Subp_Id)) + then + Subp_Id := LSP_Subprogram (Subp_Id); + end if; + + if Present (Class_Condition (Kind, Subp_Id)) then + return Subp_Id; + end if; + end loop; + end; + + return Empty; + end Nearest_Class_Condition_Subprogram; + -------------------------------- -- Nearest_Enclosing_Instance -- -------------------------------- @@ -31535,8 +31440,16 @@ package body Sem_Util is -- type case correctly, so we avoid that problem by -- returning True here. return True; + elsif Ada_Version < Ada_2022 then return False; + + elsif Inside_Class_Condition_Preanalysis then + -- No need to evaluate it during preanalysis of a class-wide + -- pre/postcondition since the expression is not installed yet + -- on its definite context. + return False; + elsif not Is_Conditionally_Evaluated (Expr) then return False; else |