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.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;
