diff options
author | Piotr Trojanek <trojanek@adacore.com> | 2023-04-05 23:55:30 +0200 |
---|---|---|
committer | Marc Poulhiès <poulhies@adacore.com> | 2023-05-29 10:23:21 +0200 |
commit | f82fb00286eb774776c5f0e1cfdfd4981764d8f6 (patch) | |
tree | 6b4636ebb282628dd953d8db78983e154093e79f /gcc/ada | |
parent | 8eb9a6b4c4b68fb39f02608787e2bd9836544cad (diff) | |
download | gcc-f82fb00286eb774776c5f0e1cfdfd4981764d8f6.zip gcc-f82fb00286eb774776c5f0e1cfdfd4981764d8f6.tar.gz gcc-f82fb00286eb774776c5f0e1cfdfd4981764d8f6.tar.bz2 |
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.
Diffstat (limited to 'gcc/ada')
-rw-r--r-- | gcc/ada/exp_aggr.adb | 3 | ||||
-rw-r--r-- | gcc/ada/sem_ch6.adb | 73 | ||||
-rw-r--r-- | 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) |