* [Ada] Removal of technical debt
@ 2022-01-06 17:12 Pierre-Marie de Rodat
0 siblings, 0 replies; 3+ messages in thread
From: Pierre-Marie de Rodat @ 2022-01-06 17:12 UTC (permalink / raw)
To: gcc-patches; +Cc: Justin Squirek
[-- Attachment #1: Type: text/plain, Size: 1673 bytes --]
This patch removes various technical debt in the form of "???" comments
throughout the GNAT sources.
Tested on x86_64-pc-linux-gnu, committed on trunk
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.
[-- Attachment #2: patch.diff --]
[-- Type: text/x-diff, Size: 22864 bytes --]
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
--- 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
--- 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
--- 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
--- 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) <Plane 15 Private Use, First> .. <Plane 15 Private Use, Last>
(16#100000#, 16#10FFFD#)); -- (Co) <Plane 16 Private Use, First> .. <Plane 16 Private Use, Last>
- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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;
^ permalink raw reply [flat|nested] 3+ messages in thread
* [Ada] Removal of technical debt
@ 2021-09-22 15:15 Pierre-Marie de Rodat
0 siblings, 0 replies; 3+ messages in thread
From: Pierre-Marie de Rodat @ 2021-09-22 15:15 UTC (permalink / raw)
To: gcc-patches; +Cc: Justin Squirek
[-- Attachment #1: Type: text/plain, Size: 1883 bytes --]
This is an iterative patch as part of a greater project to reduce the
amount of technical debt present in the frontend of the compiler.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* ali.adb, ali.ads (Scan_ALI): Remove use of deprecated
parameter Ignore_ED, and all specification for Lower in call to
Get_File_Name.
* ali-util.adb (Read_Withed_ALIs): Modify call to Scan_ALI.
* clean.adb (Clean_Executables): Likewise.
* gnatbind.adb (Add_Artificial_ALI_File, Executable section):
Likewise.
* gnatlink.adb (Executable section): Likewise.
* gnatls.adb (Executable section): Likewise.
* make.adb (Check, Wait_For_Available_Slot): Likewise.
* aspects.ads: Add Aspect_No_Controlled_Parts to
Nonoverridable_Aspect_Id
* opt.ads: Remove function pointers used as a workaround for
ASIS.
* osint-c.adb (Executable section): Remove setting of function
pointer workarounds needed for ASIS.
* osint.adb (Read_Default_Search_Dirs): Correct behavior to
detect EOL characters.
* par_sco.adb (Output_Header): Remove comment regarding use of
First_Sloc.
(Traverse_Sync_Definition): Renamed to
Traverse_Protected_Or_Task_Definition.
* pprint.adb (Interal_List_Name): Add description about purpose,
and refactor conditional statement.
(Prepend): Removed.
* repinfo.adb (List_Rep_Info, Write_Info_Line): Remove use of
subprogram pointer.
* scng.adb (Scan): Remove CODEFIX question, and minor comment
change.
* sem_attr.adb (Analyze_Image_Attribute): Remove special
processing for 'Img.
* sem_ch6.adb (Check_Untagged_Equality): Add RM reference.
(FCE): Add comment describing behavior.
(Is_Non_Overriding_Operation): Minor comment formatting change.
* sem_type.adb (Is_Actual_Subprogram): Add comment about
Comes_From_Source test.
(Matching_Types): Describe non-matching cases.
* sem_util.adb (Is_Confirming): Add stub case for
No_Controlled_Parts.
[-- Attachment #2: patch.diff --]
[-- Type: text/x-diff, Size: 22257 bytes --]
diff --git a/gcc/ada/ali-util.adb b/gcc/ada/ali-util.adb
--- a/gcc/ada/ali-util.adb
+++ b/gcc/ada/ali-util.adb
@@ -249,7 +249,6 @@ package body ALI.Util is
Scan_ALI
(F => Afile,
T => Text,
- Ignore_ED => False,
Err => False);
Free (Text);
diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb
--- a/gcc/ada/ali.adb
+++ b/gcc/ada/ali.adb
@@ -892,7 +892,6 @@ package body ALI is
function Scan_ALI
(F : File_Name_Type;
T : Text_Buffer_Ptr;
- Ignore_ED : Boolean;
Err : Boolean;
Ignore_Lines : String := "X";
Ignore_Errors : Boolean := False;
@@ -1319,8 +1318,7 @@ package body ALI is
exit when Nextc = ',';
-- Terminate if left bracket not part of wide char
- -- sequence Note that we only recognize brackets
- -- notation so far ???
+ -- sequence.
exit when Nextc = '[' and then T (P + 1) /= '"';
@@ -2938,9 +2936,7 @@ package body ALI is
-- Store AD indication unless ignore required
- if not Ignore_ED then
- Withs.Table (Withs.Last).Elab_All_Desirable := True;
- end if;
+ Withs.Table (Withs.Last).Elab_All_Desirable := True;
elsif Nextc = 'E' then
P := P + 1;
@@ -2957,12 +2953,9 @@ package body ALI is
Checkc ('D');
Check_At_End_Of_Field;
- -- Store ED indication unless ignore required
+ -- Store ED indication
- if not Ignore_ED then
- Withs.Table (Withs.Last).Elab_Desirable :=
- True;
- end if;
+ Withs.Table (Withs.Last).Elab_Desirable := True;
end if;
else
@@ -3213,13 +3206,10 @@ package body ALI is
Skip_Space;
Sdep.Increment_Last;
- -- In the following call, Lower is not set to True, this is either
- -- a bug, or it deserves a special comment as to why this is so???
-
-- The file/path name may be quoted
Sdep.Table (Sdep.Last).Sfile :=
- Get_File_Name (May_Be_Quoted => True);
+ Get_File_Name (Lower => True, May_Be_Quoted => True);
Sdep.Table (Sdep.Last).Stamp := Get_Stamp;
Sdep.Table (Sdep.Last).Dummy_Entry :=
diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads
--- a/gcc/ada/ali.ads
+++ b/gcc/ada/ali.ads
@@ -1389,7 +1389,6 @@ package ALI is
function Scan_ALI
(F : File_Name_Type;
T : Text_Buffer_Ptr;
- Ignore_ED : Boolean;
Err : Boolean;
Ignore_Lines : String := "X";
Ignore_Errors : Boolean := False;
@@ -1399,11 +1398,6 @@ package ALI is
-- table. Switch settings may be modified as described above in the
-- switch description settings.
--
- -- Ignore_ED is normally False. If set to True, it indicates that
- -- all AD/ED (elaboration desirable) indications in the ALI file are
- -- to be ignored. This parameter is obsolete now that the -f switch
- -- is removed from gnatbind, and should be removed ???
- --
-- Err determines the action taken on an incorrectly formatted file.
-- If Err is False, then an error message is output, and the program
-- is terminated. If Err is True, then no error message is output,
diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
--- a/gcc/ada/aspects.ads
+++ b/gcc/ada/aspects.ads
@@ -233,7 +233,7 @@ package Aspects is
Aspect_Implicit_Dereference | Aspect_Constant_Indexing |
Aspect_Variable_Indexing | Aspect_Aggregate |
Aspect_Max_Entry_Queue_Length
- -- | Aspect_No_Controlled_Parts
+ | Aspect_No_Controlled_Parts
-- ??? No_Controlled_Parts not yet in Aspect_Id enumeration
; -- see RM 13.1.1(18.7)
diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb
--- a/gcc/ada/clean.adb
+++ b/gcc/ada/clean.adb
@@ -217,7 +217,7 @@ package body Clean is
if Text /= null then
The_ALI :=
- Scan_ALI (Lib_File, Text, Ignore_ED => False, Err => True);
+ Scan_ALI (Lib_File, Text, Err => True);
Free (Text);
-- If no error was produced while loading this ALI file,
diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb
--- a/gcc/ada/gnatbind.adb
+++ b/gcc/ada/gnatbind.adb
@@ -125,7 +125,6 @@ procedure Gnatbind is
Scan_ALI
(F => Std_Lib_File,
T => Text,
- Ignore_ED => False,
Err => False,
Ignore_Errors => Debug_Flag_I);
@@ -770,7 +769,6 @@ begin
Id := Scan_ALI
(F => Main_Lib_File,
T => Text,
- Ignore_ED => False,
Err => False,
Ignore_Errors => Debug_Flag_I,
Directly_Scanned => True);
diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb
--- a/gcc/ada/gnatlink.adb
+++ b/gcc/ada/gnatlink.adb
@@ -1531,7 +1531,6 @@ begin
A := Scan_ALI
(F,
T,
- Ignore_ED => False,
Err => False,
Ignore_Errors => True);
diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb
--- a/gcc/ada/gnatls.adb
+++ b/gcc/ada/gnatls.adb
@@ -2278,7 +2278,6 @@ begin
Scan_ALI
(Ali_File,
Text,
- Ignore_ED => False,
Err => False,
Ignore_Errors => True);
end;
diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb
--- a/gcc/ada/make.adb
+++ b/gcc/ada/make.adb
@@ -1168,7 +1168,7 @@ package body Make is
end if;
else
- ALI := Scan_ALI (Lib_File, Text, Ignore_ED => False, Err => True);
+ ALI := Scan_ALI (Lib_File, Text, Err => True);
Free (Text);
if ALI = No_ALI_Id then
@@ -2647,7 +2647,7 @@ package body Make is
if Text /= null then
ALI :=
Scan_ALI
- (Data.Lib_File, Text, Ignore_ED => False, Err => True);
+ (Data.Lib_File, Text, Err => True);
if ALI = No_ALI_Id then
diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads
--- a/gcc/ada/opt.ads
+++ b/gcc/ada/opt.ads
@@ -1031,22 +1031,6 @@ package Opt is
-- GNATBIND
-- Set to True to enable XDR in s-stratt.adb. Set by -xdr.
- type Create_Repinfo_File_Proc is access procedure (Src : String);
- type Write_Repinfo_Line_Proc is access procedure (Info : String);
- type Close_Repinfo_File_Proc is access procedure;
- -- Types used for procedure addresses below
-
- Create_Repinfo_File_Access : Create_Repinfo_File_Proc := null;
- Write_Repinfo_Line_Access : Write_Repinfo_Line_Proc := null;
- Close_Repinfo_File_Access : Close_Repinfo_File_Proc := null;
- -- GNAT
- -- These three locations are left null when operating in non-compiler (e.g.
- -- ASIS mode), but when operating in compiler mode, they are set to point
- -- to the three corresponding procedures in Osint-C. The reason for this
- -- slightly strange interface is to stop Repinfo from dragging in Osint in
- -- ASIS mode, which would include lots of unwanted units in the ASIS build.
- -- ??? Revisit this now that ASIS mode is gone.
-
type Create_List_File_Proc is access procedure (S : String);
type Write_List_Info_Proc is access procedure (S : String);
type Close_List_File_Proc is access procedure;
diff --git a/gcc/ada/osint-c.adb b/gcc/ada/osint-c.adb
--- a/gcc/ada/osint-c.adb
+++ b/gcc/ada/osint-c.adb
@@ -520,10 +520,6 @@ package body Osint.C is
begin
Adjust_OS_Resource_Limits;
- Opt.Create_Repinfo_File_Access := Create_Repinfo_File'Access;
- Opt.Write_Repinfo_Line_Access := Write_Repinfo_Line'Access;
- Opt.Close_Repinfo_File_Access := Close_Repinfo_File'Access;
-
Opt.Create_List_File_Access := Create_List_File'Access;
Opt.Write_List_Info_Access := Write_List_Info'Access;
Opt.Close_List_File_Access := Close_List_File'Access;
diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb
--- a/gcc/ada/osint.adb
+++ b/gcc/ada/osint.adb
@@ -2373,14 +2373,12 @@ package body Osint is
Nb_Relative_Dir := 0;
for J in 1 .. Len loop
- -- Treat any control character as a path separator. Note that we do
+ -- Treat any EOL character as a path separator. Note that we do
-- not treat space as a path separator (we used to treat space as a
-- path separator in an earlier version). That way space can appear
-- as a legitimate character in a path name.
- -- Why do we treat all control characters as path separators???
-
- if S (J) in ASCII.NUL .. ASCII.US then
+ if S (J) = ASCII.LF or else S (J) = ASCII.CR then
S (J) := Path_Separator;
end if;
diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb
--- a/gcc/ada/par_sco.adb
+++ b/gcc/ada/par_sco.adb
@@ -216,9 +216,6 @@ package body Par_SCO is
-- Parameter D, when present, indicates the dominant of the first
-- declaration or statement within N.
- -- Why is Traverse_Sync_Definition commented specifically, whereas
- -- the others are not???
-
procedure Traverse_Generic_Package_Declaration (N : Node_Id);
procedure Traverse_Handled_Statement_Sequence
@@ -235,8 +232,7 @@ package body Par_SCO is
(N : Node_Id;
D : Dominant_Info := No_Dominant);
- procedure Traverse_Sync_Definition (N : Node_Id);
- -- Traverse a protected definition or task definition
+ procedure Traverse_Protected_Or_Task_Definition (N : Node_Id);
-- Note regarding traversals: In a few cases where an Alternatives list is
-- involved, pragmas such as "pragma Page" may show up before the first
@@ -690,9 +686,6 @@ package body Par_SCO is
-- fully equivalent to the "To" sloc computed by
-- Sloc_Range (Guard, To, From).
- -- Doesn't this requirement of using First_Sloc need to be
- -- documented in the spec ???
-
if Nkind (Parent (N)) in N_Accept_Alternative
| N_Delay_Alternative
| N_Terminate_Alternative
@@ -2331,7 +2324,7 @@ package body Par_SCO is
Process_Decisions_Defer (Discriminant_Specifications (N), 'X');
Set_Statement_Entry;
- Traverse_Sync_Definition (N);
+ Traverse_Protected_Or_Task_Definition (N);
when N_Single_Protected_Declaration
| N_Single_Task_Declaration
@@ -2339,7 +2332,7 @@ package body Par_SCO is
Extend_Statement_Sequence (N, 'o');
Set_Statement_Entry;
- Traverse_Sync_Definition (N);
+ Traverse_Protected_Or_Task_Definition (N);
when others =>
@@ -2517,11 +2510,11 @@ package body Par_SCO is
Traverse_Declarations_Or_Statements (Private_Declarations (Spec), Dom);
end Traverse_Package_Declaration;
- ------------------------------
- -- Traverse_Sync_Definition --
- ------------------------------
+ -------------------------------------------
+ -- Traverse_Protected_Or_Task_Definition --
+ -------------------------------------------
- procedure Traverse_Sync_Definition (N : Node_Id) is
+ procedure Traverse_Protected_Or_Task_Definition (N : Node_Id) is
Dom_Info : Dominant_Info := ('S', N);
-- The first declaration is dominated by the protected or task [type]
-- declaration.
@@ -2570,7 +2563,7 @@ package body Par_SCO is
Traverse_Declarations_Or_Statements
(L => Priv_Decl,
D => Dom_Info);
- end Traverse_Sync_Definition;
+ end Traverse_Protected_Or_Task_Definition;
--------------------------------------
-- Traverse_Subprogram_Or_Task_Body --
diff --git a/gcc/ada/pprint.adb b/gcc/ada/pprint.adb
--- a/gcc/ada/pprint.adb
+++ b/gcc/ada/pprint.adb
@@ -100,7 +100,7 @@ package body Pprint is
Add_Space : Boolean := True;
Add_Paren : Boolean := True;
Num : Natural := 1) return String;
- -- ??? what does this do
+ -- Created for purposes of recursing on embedded lists
------------------------
-- Internal_List_Name --
@@ -113,30 +113,6 @@ package body Pprint is
Add_Paren : Boolean := True;
Num : Natural := 1) return String
is
- function Prepend (S : String) return String;
- -- ??? what does this do
-
- -------------
- -- Prepend --
- -------------
-
- function Prepend (S : String) return String is
- begin
- if Add_Space then
- if Add_Paren then
- return " (" & S;
- else
- return ' ' & S;
- end if;
- elsif Add_Paren then
- return '(' & S;
- else
- return S;
- end if;
- end Prepend;
-
- -- Start of processing for Internal_List_Name
-
begin
if not Present (List) then
if First or else not Add_Paren then
@@ -152,23 +128,22 @@ package body Pprint is
end if;
end if;
- -- ??? the Internal_List_Name calls can be factored out
-
- if First then
- return Prepend (Expr_Name (List)
- & Internal_List_Name
- (List => Next (List),
- First => False,
- Add_Paren => Add_Paren,
- Num => Num + 1));
- else
- return ", " & Expr_Name (List)
- & Internal_List_Name
- (List => Next (List),
- First => False,
- Add_Paren => Add_Paren,
- Num => Num + 1);
- end if;
+ -- Continue recursing on the list - handling the first element
+ -- in a special way.
+
+ return
+ (if First then
+ (if Add_Space and Add_Paren then " ("
+ elsif Add_Paren then "("
+ elsif Add_Space then " "
+ else "")
+ else ", ")
+ & Expr_Name (List)
+ & Internal_List_Name
+ (List => Next (List),
+ First => False,
+ Add_Paren => Add_Paren,
+ Num => Num + 1);
end Internal_List_Name;
-- Start of processing for List_Name
diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb
--- a/gcc/ada/repinfo.adb
+++ b/gcc/ada/repinfo.adb
@@ -35,6 +35,7 @@ with Namet; use Namet;
with Nlists; use Nlists;
with Opt; use Opt;
with Output; use Output;
+with Osint.C; use Osint.C;
with Sem_Aux; use Sem_Aux;
with Sem_Eval; use Sem_Eval;
with Sinfo; use Sinfo;
@@ -1724,7 +1725,7 @@ package body Repinfo is
-- List representation information to file
else
- Create_Repinfo_File_Access.all
+ Create_Repinfo_File
(Get_Name_String (File_Name (Source_Index (U))));
Set_Special_Output (Write_Info_Line'Access);
if List_Representation_Info_To_JSON then
@@ -1736,7 +1737,7 @@ package body Repinfo is
Write_Line ("]");
end if;
Cancel_Special_Output;
- Close_Repinfo_File_Access.all;
+ Close_Repinfo_File;
end if;
end if;
end loop;
@@ -2328,7 +2329,7 @@ package body Repinfo is
procedure Write_Info_Line (S : String) is
begin
- Write_Repinfo_Line_Access.all (S (S'First .. S'Last - 1));
+ Write_Repinfo_Line (S (S'First .. S'Last - 1));
end Write_Info_Line;
---------------------
diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb
--- a/gcc/ada/scng.adb
+++ b/gcc/ada/scng.adb
@@ -1743,13 +1743,13 @@ package body Scng is
Code := Character'Pos (' ');
-- In Ada 95 mode we allow any wide character in a character
- -- literal, but in Ada 2005, the set of characters allowed
- -- is restricted to graphic characters.
+ -- literal, but in later versions, the set of characters
+ -- allowed is restricted to graphic characters.
elsif Ada_Version >= Ada_2005
and then Is_UTF_32_Non_Graphic (UTF_32 (Code))
then
- Error_Msg -- CODEFIX????
+ Error_Msg -- CODEFIX
("(Ada 2005) non-graphic character not permitted " &
"in character literal", Wptr);
end if;
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -1519,14 +1519,6 @@ package body Sem_Attr is
Check_E1;
Set_Etype (N, Str_Typ);
- -- ???It's not clear why 'Img should behave any differently than
- -- 'Image.
-
- if Attr_Id = Attribute_Img then
- Error_Attr_P
- ("prefix of % attribute must be a scalar object name");
- end if;
-
pragma Assert (Is_Entity_Name (P) and then Is_Type (Entity (P)));
if Ekind (Entity (P)) = E_Incomplete_Type
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -9480,13 +9480,12 @@ package body Sem_Ch6 is
end if;
-- Here if type is not frozen yet. It is illegal to have a primitive
- -- equality declared in the private part if the type is visible.
+ -- equality declared in the private part if the type is visible
+ -- (RM 4.5.2(9.8)).
elsif not In_Same_List (Parent (Typ), Decl)
and then not Is_Limited_Type (Typ)
then
- -- Shouldn't we give an RM reference here???
-
if Ada_Version >= Ada_2012 then
Error_Msg_N
("equality operator appears too late<<", Eq_Op);
@@ -9817,7 +9816,8 @@ package body Sem_Ch6 is
-- conform when they do not, e.g. by converting 1+2 into 3.
function FCE (Given_E1 : Node_Id; Given_E2 : Node_Id) return Boolean;
- -- ???
+ -- Convenience function to abbreviate recursive calls to
+ -- Fully_Conformant_Expressions without having to pass Report.
function FCL (L1 : List_Id; L2 : List_Id) return Boolean;
-- Compare elements of two lists for conformance. Elements have to be
@@ -10778,7 +10778,7 @@ package body Sem_Ch6 is
Error_Msg_Node_2 := F_Typ;
Error_Msg_NE
("private operation& in generic unit does not override "
- & "any primitive operation of& (RM 12.3 (18))??",
+ & "any primitive operation of& (RM 12.3(18))??",
New_E, New_E);
end if;
diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb
--- a/gcc/ada/sem_type.adb
+++ b/gcc/ada/sem_type.adb
@@ -1403,7 +1403,9 @@ package body Sem_Type is
and then Nkind (Unit_Declaration_Node (S)) =
N_Subprogram_Renaming_Declaration
- -- Why the Comes_From_Source test here???
+ -- Determine if the renaming came from source or was generated as a
+ -- a result of generic expansion since the actual is represented by
+ -- a constructed subprogram renaming.
and then not Comes_From_Source (Unit_Declaration_Node (S))
@@ -1460,7 +1462,8 @@ package body Sem_Type is
then
return True;
- -- ??? There are possibly other cases to consider
+ -- Formal_Typ is a private view, or Opnd_Typ and Formal_Typ are
+ -- compatible only on a base-type basis.
else
return False;
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -16264,12 +16264,14 @@ package body Sem_Util is
Names_Match (Assign_Indexed_1, Assign_Indexed_2);
end;
+ -- Checking for this aspect is performed elsewhere during freezing
+ when Aspect_No_Controlled_Parts =>
+ return True;
+
-- scalar-valued aspects; compare (static) values.
- when Aspect_Max_Entry_Queue_Length -- | Aspect_No_Controlled_Parts
- =>
- -- This should be unreachable. No_Controlled_Parts is
- -- not yet supported at all in GNAT and Max_Entry_Queue_Length
- -- is supported only for protected entries, not for types.
+ when Aspect_Max_Entry_Queue_Length =>
+ -- This should be unreachable. Max_Entry_Queue_Length is
+ -- supported only for protected entries, not for types.
pragma Assert (Serious_Errors_Detected /= 0);
return True;
^ permalink raw reply [flat|nested] 3+ messages in thread
* [Ada] Removal of technical debt
@ 2021-06-17 14:33 Pierre-Marie de Rodat
0 siblings, 0 replies; 3+ messages in thread
From: Pierre-Marie de Rodat @ 2021-06-17 14:33 UTC (permalink / raw)
To: gcc-patches; +Cc: Justin Squirek
[-- Attachment #1: Type: text/plain, Size: 1587 bytes --]
This is an iterative patch as part of a greater project to reduce the
amount of technical debt present in the frontend of the compiler.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* exp_ch3.adb (Check_Missing_Others): Add comment.
(Build_Initialization_Call): Remove inaccurate accessibility
comment.
* sem_ch12.adb (Analyze_Generic_Subprogram_Declaration): Remove
test for Ada2012.
(Analyze_Package_Instantiation): Remove speculative comment.
(Inline_Instance_Body): Add comments for loops.
(Build_Subprogram_Renaming): Remove comment about fix being
partial and "ugly."
(Instantiate_Subprogram_Body): Remove comment referencing DEC
related internal issue.
(Subtypes_Match): Add comment and simplify anonymous access
test.
(Is_Global): Add test for when E is an expanded name, and
calculate the scope accordingly.
* sem_ch6.adb (Analyze_Function_Return): Update comment
regarding accessibility, and add check for
Warn_On_Ada_2012_Compatibility.
(Mask_Type_Refs): Add comments.
(Analyze_Subprogram_Declaration): Remove mysterious suppression
of elaboration checks.
* sem_ch7.adb (Preserve_Full_Attributes): Preserve Is_Atomic
value.
* sem_ch8.adb (Most_Descendant_Use_Clause): Remove comment.
(Note_Redundant_Use): Fix calls to Find_First_Use to be
Find_Most_Prev.
(Get_Object_Name): Modify error message to be more descriptive.
(Known_But_Visible): Remove mysterious special case for
GNAT_Mode.
(Find_First_Use): Removed.
(Find_Most_Prev): Renamed from Find_First_Use.
* sem_prag.adb (Check_Static_Constraint): Add comments to
routine.
[-- Attachment #2: patch.diff --]
[-- Type: text/x-diff, Size: 19497 bytes --]
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -1502,7 +1502,8 @@ package body Exp_Ch3 is
Typ : constant Entity_Id := Etype (Discr);
procedure Check_Missing_Others (V : Node_Id);
- -- ???
+ -- Check that a given variant and its nested variants have an others
+ -- choice, and generate a constraint error raise when it does not.
--------------------------
-- Check_Missing_Others --
@@ -1871,10 +1872,6 @@ package body Exp_Ch3 is
-- Pass the extra accessibility level parameter associated with the
-- level of the object being initialized when required.
- -- When no entity is present for Id_Ref it may not have been fully
- -- analyzed, so allow the default value of standard standard to be
- -- passed ???
-
if Is_Entity_Name (Id_Ref)
and then Present (Init_Proc_Level_Formal (Proc))
then
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -3903,12 +3903,7 @@ package body Sem_Ch12 is
-- Check restriction imposed by AI05-073: a generic function
-- cannot return an abstract type or an access to such.
- -- This is a binding interpretation should it apply to earlier
- -- versions of Ada as well as Ada 2012???
-
- if Is_Abstract_Type (Designated_Type (Result_Type))
- and then Ada_Version >= Ada_2012
- then
+ if Is_Abstract_Type (Designated_Type (Result_Type)) then
Error_Msg_N
("generic function cannot have an access result "
& "that designates an abstract type", Spec);
@@ -4539,10 +4534,7 @@ package body Sem_Ch12 is
-- If the current scope is itself an instance within a child
-- unit, there will be duplications in the scope stack, and the
-- unstacking mechanism in Inline_Instance_Body will fail.
- -- This loses some rare cases of optimization, and might be
- -- improved some day, if we can find a proper abstraction for
- -- "the complete compilation context" that can be saved and
- -- restored. ???
+ -- This loses some rare cases of optimization.
if Is_Generic_Instance (Current_Scope) then
declare
@@ -4987,17 +4979,20 @@ package body Sem_Ch12 is
if Gen_Comp /= Cunit_Entity (Current_Sem_Unit) then
- -- Add some comments for the following two loops ???
+ -- Loop through enclosing scopes until we reach a generic instance,
+ -- package body, or subprogram.
S := Current_Scope;
while Present (S) and then S /= Standard_Standard loop
+
+ -- Save use clauses from enclosing scopes into Use_Clauses
+
loop
Num_Scopes := Num_Scopes + 1;
Use_Clauses (Num_Scopes) :=
(Scope_Stack.Table
- (Scope_Stack.Last - Num_Scopes + 1).
- First_Use_Clause);
+ (Scope_Stack.Last - Num_Scopes + 1).First_Use_Clause);
End_Use_Clauses (Use_Clauses (Num_Scopes));
exit when Scope_Stack.Last - Num_Scopes + 1 = Scope_Stack.First
@@ -5554,7 +5549,6 @@ package body Sem_Ch12 is
-- If there is a formal subprogram with the same name as the unit
-- itself, do not add this renaming declaration, to prevent
-- ambiguities when there is a call with that name in the body.
- -- This is a partial and ugly fix for one ACATS test. ???
Renaming_Decl := First (Renaming_List);
while Present (Renaming_Decl) loop
@@ -9764,6 +9758,7 @@ package body Sem_Ch12 is
-- point of the current enclosing instance. Pending a better usage of
-- Slocs to indicate instantiation places, we determine the place of
-- origin of a node by finding the maximum sloc of any ancestor node.
+
-- Why is this not equivalent to Top_Level_Location ???
-------------------
@@ -12576,9 +12571,7 @@ package body Sem_Ch12 is
-- errors, this may be an instance whose scope is a premature instance.
-- In that case we must insure that the (legal) program does raise
-- program error if executed. We generate a subprogram body for this
- -- purpose. See DEC ac30vso.
-
- -- Should not reference proprietary DEC tests in comments ???
+ -- purpose.
elsif Serious_Errors_Detected = 0
and then Nkind (Parent (Inst_Node)) /= N_Compilation_Unit
@@ -12705,7 +12698,7 @@ package body Sem_Ch12 is
function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean;
-- Check that base types are the same and that the subtypes match
- -- statically. Used in several of the above.
+ -- statically. Used in several of the validation subprograms.
--------------------------------------------
-- Check_Shared_Variable_Control_Aspects --
@@ -12840,7 +12833,9 @@ package body Sem_Ch12 is
T : constant Entity_Id := Get_Instance_Of (Gen_T);
begin
- -- Some detailed comments would be useful here ???
+ -- Check that the base types, root types (when dealing with class
+ -- wide types), or designated types (when dealing with anonymous
+ -- access types) of Gen_T and Act_T are statically matching subtypes.
return ((Base_Type (T) = Act_T
or else Base_Type (T) = Base_Type (Act_T))
@@ -12852,9 +12847,7 @@ package body Sem_Ch12 is
(Get_Instance_Of (Root_Type (Gen_T)),
Root_Type (Act_T)))
- or else
- (Ekind (Gen_T) in E_Anonymous_Access_Subprogram_Type
- | E_Anonymous_Access_Type
+ or else (Is_Anonymous_Access_Type (Gen_T)
and then Ekind (Act_T) = Ekind (Gen_T)
and then Subtypes_Statically_Match
(Designated_Type (Gen_T), Designated_Type (Act_T)));
@@ -15626,7 +15619,8 @@ package body Sem_Ch12 is
elsif Nkind (E) not in N_Entity then
return False;
- elsif Is_Child_Unit (E)
+ elsif Nkind (E) /= N_Expanded_Name
+ and then Is_Child_Unit (E)
and then (Is_Instance_Node (Parent (N2))
or else (Nkind (Parent (N2)) = N_Expanded_Name
and then N2 = Selector_Name (Parent (N2))
@@ -15636,7 +15630,19 @@ package body Sem_Ch12 is
return True;
else
- Se := Scope (E);
+ -- E may be an expanded name - typically an operator - in which
+ -- case we must find its enclosing scope since expanded names
+ -- don't have corresponding scopes.
+
+ if Nkind (E) = N_Expanded_Name then
+ Se := Find_Enclosing_Scope (E);
+
+ -- Otherwise, E is an entity and will have Scope set
+
+ else
+ Se := Scope (E);
+ end if;
+
while Se /= Gen_Scope loop
if Se = Standard_Standard then
return True;
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -1535,14 +1535,12 @@ package body Sem_Ch6 is
-- Check RM 6.5 (5.9/3)
if Has_Aliased then
- if Ada_Version < Ada_2012 then
-
- -- Shouldn't this test Warn_On_Ada_2012_Compatibility ???
- -- Can it really happen (extended return???)
-
+ if Ada_Version < Ada_2012
+ and then Warn_On_Ada_2012_Compatibility
+ then
Error_Msg_N
("ALIASED only allowed for limited return objects "
- & "in Ada 2012??", N);
+ & "in Ada 2012?y?", N);
elsif not Is_Limited_View (R_Type) then
Error_Msg_N
@@ -1674,9 +1672,9 @@ package body Sem_Ch6 is
Related_Nod => N);
end if;
- -- ??? A real run-time accessibility check is needed in cases
- -- involving dereferences of access parameters. For now we just
- -- check the static cases.
+ -- Perform static accessibility checks for cases involving
+ -- dereferences of access parameters. Runtime accessibility checks
+ -- get generated elsewhere.
if (Ada_Version < Ada_2005 or else Debug_Flag_Dot_L)
and then Is_Limited_View (Etype (Scope_Id))
@@ -3827,7 +3825,8 @@ package body Sem_Ch6 is
Result : Elist_Id := No_Elist;
function Mask_Type_Refs (Node : Node_Id) return Traverse_Result;
- -- Mask all types referenced in the subtree rooted at Node
+ -- Mask all types referenced in the subtree rooted at Node as
+ -- formally frozen.
--------------------
-- Mask_Type_Refs --
@@ -3835,7 +3834,8 @@ package body Sem_Ch6 is
function Mask_Type_Refs (Node : Node_Id) return Traverse_Result is
procedure Mask_Type (Typ : Entity_Id);
- -- ??? what does this do?
+ -- Mask a given type as formally frozen when outside the current
+ -- scope, or else freeze the type.
---------------
-- Mask_Type --
@@ -5665,17 +5665,6 @@ package body Sem_Ch6 is
end;
end if;
- -- What is the following code for, it used to be
-
- -- ??? Set_Suppress_Elaboration_Checks
- -- ??? (Designator, Elaboration_Checks_Suppressed (Designator));
-
- -- The following seems equivalent, but a bit dubious
-
- if Elaboration_Checks_Suppressed (Designator) then
- Set_Kill_Elaboration_Checks (Designator);
- end if;
-
-- For a compilation unit, set body required. This flag will only be
-- reset if a valid Import or Interface pragma is processed later on.
diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb
--- a/gcc/ada/sem_ch7.adb
+++ b/gcc/ada/sem_ch7.adb
@@ -2722,6 +2722,7 @@ package body Sem_Ch7 is
(Priv, Size_Known_At_Compile_Time (Full));
Set_Is_Volatile (Priv, Is_Volatile (Full));
Set_Treat_As_Volatile (Priv, Treat_As_Volatile (Full));
+ Set_Is_Atomic (Priv, Is_Atomic (Full));
Set_Is_Ada_2005_Only (Priv, Is_Ada_2005_Only (Full));
Set_Is_Ada_2012_Only (Priv, Is_Ada_2012_Only (Full));
Set_Has_Pragma_Unmodified (Priv, Has_Pragma_Unmodified (Full));
@@ -2733,7 +2734,6 @@ package body Sem_Ch7 is
if Is_Unchecked_Union (Full) then
Set_Is_Unchecked_Union (Base_Type (Priv));
end if;
- -- Why is atomic not copied here ???
if Referenced (Full) then
Set_Referenced (Priv);
diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
--- a/gcc/ada/sem_ch8.adb
+++ b/gcc/ada/sem_ch8.adb
@@ -481,11 +481,10 @@ package body Sem_Ch8 is
-- legality of selector given the scope denoted by prefix, and change node
-- N into a expanded name with a properly set Entity field.
- function Find_Most_Prev (Use_Clause : Node_Id) return Node_Id;
+ function Find_First_Use (Use_Clause : Node_Id) return Node_Id;
-- Find the most previous use clause (that is, the first one to appear in
-- the source) by traversing the previous clause chain that exists in both
-- N_Use_Package_Clause nodes and N_Use_Type_Clause nodes.
- -- ??? a better subprogram name is in order
function Find_Renamed_Entity
(N : Node_Id;
@@ -529,7 +528,6 @@ package body Sem_Ch8 is
Clause2 : Entity_Id) return Entity_Id;
-- Determine which use clause parameter is the most descendant in terms of
-- scope.
- -- ??? a better subprogram name is in order
procedure Premature_Usage (N : Node_Id);
-- Diagnose usage of an entity before it is visible
@@ -1168,7 +1166,9 @@ package body Sem_Ch8 is
and then Is_Anonymous_Access_Type (Etype (Expression (Nam)))
and then not Is_Anonymous_Access_Type (T)
then
- Wrong_Type (Expression (Nam), T); -- Should we give better error???
+ Error_Msg_NE
+ ("cannot rename anonymous access object "
+ & "as a named access type", Expression (Nam), T);
end if;
-- Check that a class-wide object is not being renamed as an object
@@ -5314,16 +5314,6 @@ package body Sem_Ch8 is
elsif not Comes_From_Source (E) then
return False;
-
- -- In gnat internal mode, we consider all entities known. The
- -- historical reason behind this discrepancy is not known??? But the
- -- only effect is to modify the error message given, so it is not
- -- critical. Since it only affects the exact wording of error
- -- messages in illegal programs, we do not mention this as an
- -- effect of -gnatg, since it is not a language modification.
-
- elsif GNAT_Mode then
- return True;
end if;
-- Here we have an entity that is not from package Standard, and
@@ -6989,10 +6979,10 @@ package body Sem_Ch8 is
end Find_Expanded_Name;
--------------------
- -- Find_Most_Prev --
+ -- Find_First_Use --
--------------------
- function Find_Most_Prev (Use_Clause : Node_Id) return Node_Id is
+ function Find_First_Use (Use_Clause : Node_Id) return Node_Id is
Curr : Node_Id;
begin
@@ -7004,7 +6994,7 @@ package body Sem_Ch8 is
end loop;
return Curr;
- end Find_Most_Prev;
+ end Find_First_Use;
-------------------------
-- Find_Renamed_Entity --
@@ -9804,16 +9794,16 @@ package body Sem_Ch8 is
if Present (Redundant) and then Parent (Redundant) /= Prev_Use then
-- Make sure we are looking at most-descendant use_package_clause
- -- by traversing the chain with Find_Most_Prev and then verifying
+ -- by traversing the chain with Find_First_Use and then verifying
-- there is no scope manipulation via Most_Descendant_Use_Clause.
if Nkind (Prev_Use) = N_Use_Package_Clause
and then
(Nkind (Parent (Prev_Use)) /= N_Compilation_Unit
or else Most_Descendant_Use_Clause
- (Prev_Use, Find_Most_Prev (Prev_Use)) /= Prev_Use)
+ (Prev_Use, Find_First_Use (Prev_Use)) /= Prev_Use)
then
- Prev_Use := Find_Most_Prev (Prev_Use);
+ Prev_Use := Find_First_Use (Prev_Use);
end if;
Error_Msg_Sloc := Sloc (Prev_Use);
@@ -10367,7 +10357,7 @@ package body Sem_Ch8 is
if Present (Current_Use_Clause (T)) then
Use_Clause_Known : declare
Clause1 : constant Node_Id :=
- Find_Most_Prev (Current_Use_Clause (T));
+ Find_First_Use (Current_Use_Clause (T));
Clause2 : constant Node_Id := Parent (Id);
Ent1 : Entity_Id;
Ent2 : Entity_Id;
@@ -10507,10 +10497,10 @@ package body Sem_Ch8 is
-- a spurious warning - so verify there is a previous use clause.
if Current_Use_Clause (Scope (T)) /=
- Find_Most_Prev (Current_Use_Clause (Scope (T)))
+ Find_First_Use (Current_Use_Clause (Scope (T)))
then
Error_Msg_Sloc :=
- Sloc (Find_Most_Prev (Current_Use_Clause (Scope (T))));
+ Sloc (Find_First_Use (Current_Use_Clause (Scope (T))));
Error_Msg_NE -- CODEFIX
("& is already use-visible through package use clause #??",
Id, T);
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -4083,9 +4083,9 @@ package body Sem_Prag is
procedure Check_Static_Constraint (Constr : Node_Id);
-- Constr is a constraint from an N_Subtype_Indication node from a
- -- component constraint in an Unchecked_Union type. This routine checks
- -- that the constraint is static as required by the restrictions for
- -- Unchecked_Union.
+ -- component constraint in an Unchecked_Union type, a range, or a
+ -- discriminant association. This routine checks that the constraint
+ -- is static as required by the restrictions for Unchecked_Union.
procedure Check_Valid_Configuration_Pragma;
-- Legality checks for placement of a configuration pragma
@@ -6458,11 +6458,6 @@ package body Sem_Prag is
-- Check_Static_Constraint --
-----------------------------
- -- Note: for convenience in writing this procedure, in addition to
- -- the officially (i.e. by spec) allowed argument which is always a
- -- constraint, it also allows ranges and discriminant associations.
- -- Above is not clear ???
-
procedure Check_Static_Constraint (Constr : Node_Id) is
procedure Require_Static (E : Node_Id);
@@ -6893,7 +6888,7 @@ package body Sem_Prag is
Proc : Entity_Id := Empty;
begin
- -- The body of this procedure needs some comments ???
+ -- Perform sanity checks on Name
if not Is_Entity_Name (Name) then
Error_Pragma_Arg
@@ -6909,6 +6904,9 @@ package body Sem_Prag is
("argument of pragma% must be parameterless procedure", Arg);
end if;
+ -- Otherwise, search through interpretations looking for one which
+ -- has no parameters.
+
else
declare
Found : Boolean := False;
@@ -6923,10 +6921,17 @@ package body Sem_Prag is
if Ekind (Proc) = E_Procedure
and then No (First_Formal (Proc))
then
+ -- We found an interpretation, note it and continue
+ -- looking looking to verify it is unique.
+
if not Found then
Found := True;
Set_Entity (Name, Proc);
Set_Is_Overloaded (Name, False);
+
+ -- Two procedures with the same name, log an error
+ -- since the name is ambiguous.
+
else
Error_Pragma_Arg
("ambiguous handler name for pragma%", Arg);
@@ -6937,9 +6942,13 @@ package body Sem_Prag is
end loop;
if not Found then
+ -- Issue an error if we haven't found a suitable match for
+ -- Name.
+
Error_Pragma_Arg
("argument of pragma% must be parameterless procedure",
Arg);
+
else
Proc := Entity (Name);
end if;
^ permalink raw reply [flat|nested] 3+ messages in thread
end of thread, other threads:[~2022-01-06 17:12 UTC | newest]
Thread overview: 3+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-01-06 17:12 [Ada] Removal of technical debt Pierre-Marie de Rodat
-- strict thread matches above, loose matches on Subject: below --
2021-09-22 15:15 Pierre-Marie de Rodat
2021-06-17 14:33 Pierre-Marie de Rodat
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).