[COMMITTED] ada: Cleanup detection of type support subprogram entities
Commit Message
From: Piotr Trojanek <trojanek@adacore.com>
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.
Tested on x86_64-pc-linux-gnu, committed on master.
---
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(-)
@@ -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
@@ -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;
@@ -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)