From: Justin Squirek Date: Mon, 22 Nov 2021 12:53:56 +0000 (+0000) Subject: [Ada] Removal of technical debt X-Git-Tag: basepoints/gcc-13~2020 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=4458909a806825bc9a74b69e14c7fb88a551b800;p=thirdparty%2Fgcc.git [Ada] Removal of technical debt gcc/ada/ * exp_ch6.adb (Add_Simple_Call_By_Copy_Code): Add comments regarding special handling of components which depend on discriminants. * exp_dist.adb (Build_From_Any_Function): Add Real_Rep actual for calls to Has_Stream_Attribute_Definition. (Build_To_Any_Function): Likewise. (Build_TypeCode_Function): Likewise. * freeze.adb (Freeze_Entity): Add missing comment for Test_E. * libgnat/s-utf_32.adb: Remove disabled warning comments and temporarily inserted pragma warnings. Remove very old (2006 and 2012) comments about bootstrapping older versions. * par.adb (P_Identifier): Add new parameter Force_Msg. * par-ch2.adb (P_Identifier): Restructure and clean up function. * par-ch3.adb (P_Defining_Identifier): Remove code duplication for parsing identifiers. * sem_attr.adb (Stream_Attribute_Available): Add missing comments and add Real_Rep actual for calls to Has_Stream_Attribute_Definition. * sem_cat.adb (Has_Read_Write_Attribute): Add Real_Rep actual for calls to Has_Stream_Attribute_Definition. (Has_Stream_Attribute_Definition): Remove local Real_Rep and fix recursive calls. Add default value for Real_Rep. * sem_cat.ads (Has_Stream_Attribute_Definition): Add new out parameter "Real_Rep". * sem_type.adb (Add_Entry): Add condition to avoid passing non-function calls to Function_Interp_Has_Abstract_Op. (Function_Interp_Has_Abstract_Op): Add missing comments and remove check for Is_Overloadable. * sem_util.adb (Derivation_Too_Early_To_Inherit): Remove duplicated code. --- diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index f433fa7a1656..c18d8389e102 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -1899,7 +1899,7 @@ package body Exp_Ch6 is Reset_Packed_Prefix; - Temp := Make_Temporary (Loc, 'T', Actual); + Temp := Make_Temporary (Loc, 'T', Actual); Incod := Relocate_Node (Actual); Outcod := New_Copy_Tree (Incod); @@ -1921,7 +1921,10 @@ package body Exp_Ch6 is elsif Inside_Init_Proc then - -- Could use a comment here to match comment below ??? + -- Skip using the actual as the expression in Decl if we are in + -- an init proc and it is not a component which depends on a + -- discriminant, because, in this case, we need to use the actual + -- type of the component instead. if Nkind (Actual) /= N_Selected_Component or else @@ -1930,8 +1933,9 @@ package body Exp_Ch6 is then Incod := Empty; - -- Otherwise, keep the component in order to generate the proper - -- actual subtype, that depends on enclosing discriminants. + -- Otherwise, keep the component so we can generate the proper + -- actual subtype - since the subtype depends on enclosing + -- discriminants. else null; diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index 41c0aea8a367..f6066500d980 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -8600,6 +8600,8 @@ package body Exp_Dist is Use_Opaque_Representation : Boolean; + Real_Rep : Node_Id; + begin -- For a derived type, we can't go past the base type (to the -- parent type) here, because that would cause the attribute's @@ -8634,10 +8636,10 @@ package body Exp_Dist is Use_Opaque_Representation := False; if Has_Stream_Attribute_Definition - (Typ, TSS_Stream_Output, At_Any_Place => True) + (Typ, TSS_Stream_Output, Real_Rep, At_Any_Place => True) or else Has_Stream_Attribute_Definition - (Typ, TSS_Stream_Write, At_Any_Place => True) + (Typ, TSS_Stream_Write, Real_Rep, At_Any_Place => True) then -- If user-defined stream attributes are specified for this -- type, use them and transmit data as an opaque sequence of @@ -9438,6 +9440,8 @@ package body Exp_Dist is -- When True, use stream attributes and represent type as an -- opaque sequence of bytes. + Real_Rep : Node_Id; + begin -- For a derived type, we can't go past the base type (to the -- parent type) here, because that would cause the attribute's @@ -9492,10 +9496,10 @@ package body Exp_Dist is Use_Opaque_Representation := False; if Has_Stream_Attribute_Definition - (Typ, TSS_Stream_Output, At_Any_Place => True) + (Typ, TSS_Stream_Output, Real_Rep, At_Any_Place => True) or else Has_Stream_Attribute_Definition - (Typ, TSS_Stream_Write, At_Any_Place => True) + (Typ, TSS_Stream_Write, Real_Rep, At_Any_Place => True) then -- If user-defined stream attributes are specified for this -- type, use them and transmit data as an opaque sequence of @@ -10624,6 +10628,8 @@ package body Exp_Dist is Type_Name_Str : String_Id; Type_Repo_Id_Str : String_Id; + Real_Rep : Node_Id; + -- Start of processing for Build_TypeCode_Function begin @@ -10657,10 +10663,10 @@ package body Exp_Dist is (Type_Name_Str, Type_Repo_Id_Str, Parameters); if Has_Stream_Attribute_Definition - (Typ, TSS_Stream_Output, At_Any_Place => True) + (Typ, TSS_Stream_Output, Real_Rep, At_Any_Place => True) or else Has_Stream_Attribute_Definition - (Typ, TSS_Stream_Write, At_Any_Place => True) + (Typ, TSS_Stream_Write, Real_Rep, At_Any_Place => True) then -- If user-defined stream attributes are specified for this -- type, use them and transmit data as an opaque sequence of diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index bd03ffa5844f..32a82fb7933b 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -2711,7 +2711,11 @@ package body Freeze is -- List of freezing actions, left at No_List if none Test_E : Entity_Id := E; - -- This could use a comment ??? + -- A local temporary used to test if freezing is necessary for E, since + -- its value can be set to something other than E in certain cases. For + -- example, E cannot be used directly in cases such as when it is an + -- Itype defined within a record - since it is the location of record + -- which matters. procedure Add_To_Result (Fnod : Node_Id); -- Add freeze action Fnod to list Result diff --git a/gcc/ada/libgnat/s-utf_32.adb b/gcc/ada/libgnat/s-utf_32.adb index ee3ab4ffe0b8..18eb5716ad9d 100644 --- a/gcc/ada/libgnat/s-utf_32.adb +++ b/gcc/ada/libgnat/s-utf_32.adb @@ -29,16 +29,13 @@ -- -- ------------------------------------------------------------------------------ -pragma Style_Checks (Off); --- Allow long lines in this unit. Note this could be more specific, but we --- keep this simple form because of bootstrap constraints ??? +pragma Style_Checks ("M512"); +-- Allow long lines in this unit --- pragma Warnings (Off, "non-static constant in preelaborated unit"); --- We need this to be pure, and the three constants in question are not a --- real problem, they are completely known at compile time. This pragma --- is commented out for now, because we still want to be able to bootstrap --- with old versions of the compiler that did not support this form. We --- have added additional pragma Warnings (Off/On) for now ??? +pragma Warnings (Off, "non-static constant in preelaborated unit"); +-- We need package to be pure, and multiple constants in this unit will +-- trigger the "non-static" warning - so ignore this since they are known at +-- compile time and not a real problem for us. package body System.UTF_32 is @@ -1856,9 +1853,6 @@ package body System.UTF_32 is (16#F0000#, 16#FFFFD#), -- (Co) .. (16#100000#, 16#10FFFD#)); -- (Co) .. - pragma Warnings (Off); - -- Temporary, until pragma at start can be activated ??? - -- The following array is parallel to the Unicode_Ranges table above. For -- each entry in the Unicode_Ranges table, there is a corresponding entry -- in the following table indicating the corresponding unicode category. @@ -6506,9 +6500,6 @@ package body System.UTF_32 is (16#1FBF0#, 16#1FBF9#), -- SEGMENTED DIGIT ZERO..SEGMENTED DIGIT NINE (16#2F800#, 16#2FA1D#)); -- CJK COMPATIBILITY IDEOGRAPH-2F800..CJK COMPATIBILITY IDEOGRAPH-2FA1D - pragma Warnings (On); - -- Temporary until pragma Warnings at start can be activated ??? - type Decomposition_Mapping is record Item : UTF_32; First_Char_Mapping : UTF_32; @@ -12312,7 +12303,7 @@ package body System.UTF_32 is return C = Nd; end Is_UTF_32_Digit; - ---------------------- + ---------------------- -- Is_UTF_32_Letter -- ---------------------- diff --git a/gcc/ada/par-ch2.adb b/gcc/ada/par-ch2.adb index cb60614685a0..69cc135f76f4 100644 --- a/gcc/ada/par-ch2.adb +++ b/gcc/ada/par-ch2.adb @@ -62,28 +62,24 @@ package body Ch2 is -- Error recovery: can raise Error_Resync (cannot return Error) - function P_Identifier (C : Id_Check := None) return Node_Id is + function P_Identifier + (C : Id_Check := None; + Force_Msg : Boolean := False) + return Node_Id + is Ident_Node : Node_Id; begin -- All set if we do indeed have an identifier - -- Code duplication, see Par_Ch3.P_Defining_Identifier??? - if Token = Tok_Identifier then Check_Future_Keyword; - Ident_Node := Token_Node; - Scan; -- past Identifier - return Ident_Node; -- If we have a reserved identifier, manufacture an identifier with -- a corresponding name after posting an appropriate error message elsif Is_Reserved_Identifier (C) then - Scan_Reserved_Identifier (Force_Msg => False); - Ident_Node := Token_Node; - Scan; -- past the node - return Ident_Node; + Scan_Reserved_Identifier (Force_Msg => Force_Msg); -- Otherwise we have junk that cannot be interpreted as an identifier @@ -91,6 +87,15 @@ package body Ch2 is T_Identifier; -- to give message raise Error_Resync; end if; + + if Style_Check then + Style.Check_Defining_Identifier_Casing; + end if; + + Ident_Node := Token_Node; + Scan; -- past the identifier + + return Ident_Node; end P_Identifier; -------------------------- diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index a225cf367ee4..d4cfd5559b58 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -209,39 +209,9 @@ package body Ch3 is -- Error recovery: can raise Error_Resync function P_Defining_Identifier (C : Id_Check := None) return Node_Id is - Ident_Node : Node_Id; + Ident_Node : Node_Id := P_Identifier (C, True); begin - -- Scan out the identifier. Note that this code is essentially identical - -- to P_Identifier, except that in the call to Scan_Reserved_Identifier - -- we set Force_Msg to True, since we want at least one message for each - -- separate declaration (but not use) of a reserved identifier. - - -- Duplication should be removed, common code should be factored??? - - if Token = Tok_Identifier then - Check_Future_Keyword; - - -- If we have a reserved identifier, manufacture an identifier with - -- a corresponding name after posting an appropriate error message - - elsif Is_Reserved_Identifier (C) then - Scan_Reserved_Identifier (Force_Msg => True); - - -- Otherwise we have junk that cannot be interpreted as an identifier - - else - T_Identifier; -- to give message - raise Error_Resync; - end if; - - if Style_Check then - Style.Check_Defining_Identifier_Casing; - end if; - - Ident_Node := Token_Node; - Scan; -- past the identifier - -- If we already have a defining identifier, clean it out and make -- a new clean identifier. This situation arises in some error cases -- and we need to fix it. diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 312c41100d5e..c577d283c428 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -649,10 +649,16 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- procedure more than once for the same pragma. All parse-time pragma -- handling must be prepared to handle such multiple calls correctly. - function P_Identifier (C : Id_Check := None) return Node_Id; + function P_Identifier + (C : Id_Check := None; + Force_Msg : Boolean := False) return Node_Id; -- Scans out an identifier. The parameter C determines the treatment -- of reserved identifiers. See declaration of Id_Check for details. + -- An appropriate error message, pointing to the token, is also issued + -- if either this is the first occurrence of misuse of this identifier, + -- or if Force_Msg is True. + function P_Pragmas_Opt return List_Id; -- This function scans for a sequence of pragmas in other than a -- declaration sequence or statement sequence context. All pragmas diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index ef7437a0dd0d..2cd8c1403003 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -12555,20 +12555,29 @@ package body Sem_Attr is is Etyp : Entity_Id := Typ; + Real_Rep : Node_Id; + -- Start of processing for Stream_Attribute_Available begin - -- We need some comments in this body ??? + -- Test if the attribute is specified directly on the type - if Has_Stream_Attribute_Definition (Typ, Nam) then + if Has_Stream_Attribute_Definition (Typ, Nam, Real_Rep) then return True; end if; + -- We assume class-wide types have stream attributes + -- when they are not limited. Otherwise we recurse on the + -- parent type. + if Is_Class_Wide_Type (Typ) then return not Is_Limited_Type (Typ) or else Stream_Attribute_Available (Etype (Typ), Nam); end if; + -- Non-class-wide abstract types cannot have Input streams + -- specified. + if Nam = TSS_Stream_Input and then Is_Abstract_Type (Typ) and then not Is_Class_Wide_Type (Typ) @@ -12576,6 +12585,8 @@ package body Sem_Attr is return False; end if; + -- Otherwise, nonlimited types have stream attributes + if not (Is_Limited_Type (Typ) or else (Present (Partial_View) and then Is_Limited_Type (Partial_View))) @@ -12587,13 +12598,13 @@ package body Sem_Attr is if Nam = TSS_Stream_Input and then Ada_Version >= Ada_2005 - and then Stream_Attribute_Available (Etyp, TSS_Stream_Read) + and then Stream_Attribute_Available (Etyp, TSS_Stream_Read, Real_Rep) then return True; elsif Nam = TSS_Stream_Output and then Ada_Version >= Ada_2005 - and then Stream_Attribute_Available (Etyp, TSS_Stream_Write) + and then Stream_Attribute_Available (Etyp, TSS_Stream_Write, Real_Rep) then return True; end if; @@ -12607,7 +12618,7 @@ package body Sem_Attr is begin Etyp := Etype (Etyp); - if Has_Stream_Attribute_Definition (Etyp, Nam) then + if Has_Stream_Attribute_Definition (Etyp, Nam, Real_Rep) then if not Derivation_Too_Early_To_Inherit (Derived_Type, Nam) then return True; end if; diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb index 6270b7c7aa55..bf03e8a1b200 100644 --- a/gcc/ada/sem_cat.adb +++ b/gcc/ada/sem_cat.adb @@ -432,12 +432,13 @@ package body Sem_Cat is ------------------------------- function Has_Read_Write_Attributes (E : Entity_Id) return Boolean is + Real_Rep : Node_Id; begin return True and then Has_Stream_Attribute_Definition - (E, TSS_Stream_Read, At_Any_Place => True) + (E, TSS_Stream_Read, Real_Rep, At_Any_Place => True) and then Has_Stream_Attribute_Definition - (E, TSS_Stream_Write, At_Any_Place => True); + (E, TSS_Stream_Write, Real_Rep, At_Any_Place => True); end Has_Read_Write_Attributes; ------------------------------------- @@ -447,18 +448,11 @@ package body Sem_Cat is function Has_Stream_Attribute_Definition (Typ : Entity_Id; Nam : TSS_Name_Type; + Real_Rep : out Node_Id; At_Any_Place : Boolean := False) return Boolean is Rep_Item : Node_Id; - Real_Rep : Node_Id; - -- The stream operation may be specified by an attribute definition - -- clause in the source, or by an aspect that generates such an - -- attribute definition. For an aspect, the generated attribute - -- definition may be placed at the freeze point of the full view of - -- the type, but the aspect specification makes the operation visible - -- to a client wherever the partial view is visible. - begin -- We start from the declaration node and then loop until the end of -- the list until we find the requested attribute definition clause. @@ -467,6 +461,8 @@ package body Sem_Cat is -- inserted by the expander at the point where the clause occurs), -- unless At_Any_Place is true. + Real_Rep := Empty; + Rep_Item := First_Rep_Item (Typ); while Present (Rep_Item) loop Real_Rep := Rep_Item; @@ -511,7 +507,7 @@ package body Sem_Cat is and then Present (Full_View (Typ)) then return Has_Stream_Attribute_Definition - (Underlying_Type (Typ), Nam, At_Any_Place); + (Underlying_Type (Typ), Nam, Real_Rep, At_Any_Place); -- Otherwise, if At_Any_Place is true, return True if the attribute is -- available at any place; if it is false, return True only if the diff --git a/gcc/ada/sem_cat.ads b/gcc/ada/sem_cat.ads index 90a713bd8711..3b3600646d95 100644 --- a/gcc/ada/sem_cat.ads +++ b/gcc/ada/sem_cat.ads @@ -43,6 +43,7 @@ package Sem_Cat is function Has_Stream_Attribute_Definition (Typ : Entity_Id; Nam : TSS_Name_Type; + Real_Rep : out Node_Id; At_Any_Place : Boolean := False) return Boolean; -- True when there is a attribute definition clause specifying attribute -- Nam for Typ. In Ada 2005 mode, returns True only when the attribute @@ -54,6 +55,14 @@ package Sem_Cat is -- specific type, excluding inherited definitions, the flags -- Has_Specified_Stream_* can be used instead). + -- The stream operation may be specified by an attribute definition + -- clause in the source, or by an aspect that generates such an + -- attribute definition. For an aspect, the generated attribute + -- definition may be placed at the freeze point of the full view of + -- the type, but the aspect specification makes the operation visible + -- to a client wherever the partial view is visible. This real + -- representation is returned in the Real_Rep parameter. + function In_Preelaborated_Unit return Boolean; -- Determines if the current scope is within a preelaborated compilation -- unit, that is one to which one of the pragmas Preelaborate, Pure, diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 4419fb31bdac..cbb00fd47639 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -235,7 +235,9 @@ package body Sem_Type is if Ada_Version >= Ada_2005 then if Nkind (N) in N_Binary_Op then Abstr_Op := Binary_Op_Interp_Has_Abstract_Op (N, Name); - elsif Nkind (N) = N_Function_Call then + elsif Nkind (N) = N_Function_Call + and then Ekind (Name) = E_Function + then Abstr_Op := Function_Interp_Has_Abstract_Op (N, Name); end if; end if; @@ -2357,19 +2359,24 @@ package body Sem_Type is Form_Parm : Node_Id; begin - -- Why is check on E needed below ??? - -- In any case this para needs comments ??? + if Is_Overloaded (N) then + -- Move through the formals and actuals of the call to + -- determine if an abstract interpretation exists. - if Is_Overloaded (N) and then Is_Overloadable (E) then Act_Parm := First_Actual (N); Form_Parm := First_Formal (E); while Present (Act_Parm) and then Present (Form_Parm) loop Act := Act_Parm; + -- Extract the actual from a parameter association + if Nkind (Act) = N_Parameter_Association then Act := Explicit_Actual_Parameter (Act); end if; + -- Use the actual and the type of its correponding formal to test + -- for an abstract interpretation and return it when found. + Abstr_Op := Has_Abstract_Op (Act, Etype (Form_Parm)); if Present (Abstr_Op) then @@ -2381,6 +2388,8 @@ package body Sem_Type is end loop; end if; + -- Otherwise, return empty + return Empty; end Function_Interp_Has_Abstract_Op; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index bfe15fa96f62..5c05e844e40f 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -7705,62 +7705,30 @@ package body Sem_Util is function Derivation_Too_Early_To_Inherit (Typ : Entity_Id; Streaming_Op : TSS_Name_Type) return Boolean is + Btyp : constant Entity_Id := Implementation_Base_Type (Typ); Parent_Type : Entity_Id; + + Real_Rep : Node_Id; + + -- Start of processing for Derivation_Too_Early_To_Inherit + begin if Is_Derived_Type (Btyp) then Parent_Type := Implementation_Base_Type (Etype (Btyp)); pragma Assert (Parent_Type /= Btyp); + if Has_Stream_Attribute_Definition - (Parent_Type, Streaming_Op) + (Parent_Type, Streaming_Op, Real_Rep => Real_Rep) + and then In_Same_Extended_Unit (Btyp, Parent_Type) and then Instantiation (Get_Source_File_Index (Sloc (Btyp))) = Instantiation (Get_Source_File_Index (Sloc (Parent_Type))) then - declare - -- ??? Avoid code duplication here with - -- Sem_Cat.Has_Stream_Attribute_Definition by introducing a - -- new function to be called from both places? - - Rep_Item : Node_Id := First_Rep_Item (Parent_Type); - Real_Rep : Node_Id; - Found : Boolean := False; - begin - while Present (Rep_Item) loop - Real_Rep := Rep_Item; - - if Nkind (Rep_Item) = N_Aspect_Specification then - Real_Rep := Aspect_Rep_Item (Rep_Item); - end if; - - if Nkind (Real_Rep) = N_Attribute_Definition_Clause then - case Chars (Real_Rep) is - when Name_Read => - Found := Streaming_Op = TSS_Stream_Read; - - when Name_Write => - Found := Streaming_Op = TSS_Stream_Write; - - when Name_Input => - Found := Streaming_Op = TSS_Stream_Input; - - when Name_Output => - Found := Streaming_Op = TSS_Stream_Output; - - when others => - null; - end case; - end if; - - if Found then - return Earlier_In_Extended_Unit (Btyp, Real_Rep); - end if; - - Next_Rep_Item (Rep_Item); - end loop; - end; + return Earlier_In_Extended_Unit (Btyp, Real_Rep); end if; end if; + return False; end Derivation_Too_Early_To_Inherit;