From f82fb00286eb774776c5f0e1cfdfd4981764d8f6 Mon Sep 17 00:00:00 2001 From: Piotr Trojanek Date: Wed, 5 Apr 2023 23:55:30 +0200 Subject: ada: Cleanup detection of type support subprogram entities Avoid repeated calls to Get_TSS_Name. Code cleanup related to handling of dispatching operations in GNATprove; semantics is unaffected. gcc/ada/ * exp_aggr.adb (Convert_Aggr_In_Allocator): Replace Get_TSS_Name with a high-level Is_TSS. * sem_ch6.adb (Check_Conformance): Replace DECLARE block and nested IF with a call to Get_TSS_Name and a membership test. (Has_Reliable_Extra_Formals): Refactor repeated calls to Get_TSS_Name. * sem_disp.adb (Check_Dispatching_Operation): Replace repeated calls to Get_TSS_Name with a membership test. --- gcc/ada/exp_aggr.adb | 3 +-- gcc/ada/sem_ch6.adb | 73 ++++++++++++++++++++++------------------------------ gcc/ada/sem_disp.adb | 6 ++--- 3 files changed, 35 insertions(+), 47 deletions(-) diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index c4a016e..93fcac5 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -4487,8 +4487,7 @@ package body Exp_Aggr is while Present (Stmt) loop if Nkind (Stmt) = N_Procedure_Call_Statement - and then Get_TSS_Name (Entity (Name (Stmt))) - = TSS_Slice_Assign + and then Is_TSS (Entity (Name (Stmt)), TSS_Slice_Assign) then Param := First (Parameter_Associations (Stmt)); Insert_Actions diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 495e8b1..17c50f6 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -6005,41 +6005,35 @@ package body Sem_Ch6 is -- avoids some redundant error messages. and then not Error_Posted (New_Formal) - then - -- It is allowed to omit the null-exclusion in case of stream - -- attribute subprograms. We recognize stream subprograms - -- through their TSS-generated suffix. - declare - TSS_Name : constant TSS_Name_Type := Get_TSS_Name (New_Id); + -- It is allowed to omit the null-exclusion in case of stream + -- attribute subprograms. We recognize stream subprograms + -- through their TSS-generated suffix. - begin - if TSS_Name /= TSS_Stream_Read - and then TSS_Name /= TSS_Stream_Write - and then TSS_Name /= TSS_Stream_Input - and then TSS_Name /= TSS_Stream_Output - then - -- Here we have a definite conformance error. It is worth - -- special casing the error message for the case of a - -- controlling formal (which excludes null). + and then Get_TSS_Name (New_Id) not in TSS_Stream_Read + | TSS_Stream_Write + | TSS_Stream_Input + | TSS_Stream_Output + then + -- Here we have a definite conformance error. It is worth + -- special casing the error message for the case of a + -- controlling formal (which excludes null). - if Is_Controlling_Formal (New_Formal) then - Error_Msg_Node_2 := Scope (New_Formal); - Conformance_Error - ("\controlling formal & of & excludes null, " - & "declaration must exclude null as well", - New_Formal); + if Is_Controlling_Formal (New_Formal) then + Error_Msg_Node_2 := Scope (New_Formal); + Conformance_Error + ("\controlling formal & of & excludes null, " + & "declaration must exclude null as well", + New_Formal); - -- Normal case (couldn't we give more detail here???) + -- Normal case (couldn't we give more detail here???) - else - Conformance_Error - ("\type of & does not match!", New_Formal); - end if; + else + Conformance_Error + ("\type of & does not match!", New_Formal); + end if; - return; - end if; - end; + return; end if; end if; @@ -10650,21 +10644,16 @@ package body Sem_Ch6 is else declare - Typ : constant Entity_Id := - Underlying_Type (Find_Dispatching_Type (Alias_E)); + TSS_Name : constant TSS_Name_Type := Get_TSS_Name (E); + Typ : constant Entity_Id := + Underlying_Type (Find_Dispatching_Type (Alias_E)); begin - if (Get_TSS_Name (E) = TSS_Stream_Input - and then not Stream_Operation_OK (Typ, TSS_Stream_Input)) - or else - (Get_TSS_Name (E) = TSS_Stream_Output - and then not Stream_Operation_OK (Typ, TSS_Stream_Output)) - or else - (Get_TSS_Name (E) = TSS_Stream_Read - and then not Stream_Operation_OK (Typ, TSS_Stream_Read)) - or else - (Get_TSS_Name (E) = TSS_Stream_Write - and then not Stream_Operation_OK (Typ, TSS_Stream_Write)) + if TSS_Name in TSS_Stream_Input + | TSS_Stream_Output + | TSS_Stream_Read + | TSS_Stream_Write + and then not Stream_Operation_OK (Typ, TSS_Name) then return False; end if; diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index ab409d3..6c8212c 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -1414,9 +1414,9 @@ package body Sem_Disp is and then Is_Null_Interface_Primitive (Ultimate_Alias (Old_Subp))) - or else Get_TSS_Name (Subp) = TSS_Stream_Read - or else Get_TSS_Name (Subp) = TSS_Stream_Write - or else Get_TSS_Name (Subp) = TSS_Put_Image + or else Get_TSS_Name (Subp) in TSS_Stream_Read + | TSS_Stream_Write + | TSS_Put_Image or else (Is_Wrapper (Subp) -- cgit v1.1