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 --
-- 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
-- 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);
-- 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
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
-- 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
-- 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 ???
-------------------
-- 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
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 --
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))
(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)));
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))
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;
-- 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
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))
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 --
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 --
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.
(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));
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);
-- 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;
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
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
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
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
end loop;
return Curr;
- end Find_Most_Prev;
+ end Find_First_Use;
-------------------------
-- Find_Renamed_Entity --
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);
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;
-- 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);
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
-- 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);
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
("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;
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);
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;