aboutsummaryrefslogtreecommitdiff
path: root/gcc/ada
diff options
context:
space:
mode:
authorPiotr Trojanek <trojanek@adacore.com>2023-04-05 23:55:30 +0200
committerMarc Poulhiès <poulhies@adacore.com>2023-05-29 10:23:21 +0200
commitf82fb00286eb774776c5f0e1cfdfd4981764d8f6 (patch)
tree6b4636ebb282628dd953d8db78983e154093e79f /gcc/ada
parent8eb9a6b4c4b68fb39f02608787e2bd9836544cad (diff)
downloadgcc-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.adb3
-rw-r--r--gcc/ada/sem_ch6.adb73
-rw-r--r--gcc/ada/sem_disp.adb6
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)