Skip to content

R
riscv-gcc-1
Commit d81b4bfe by Thomas Quinot Committed by Arnaud Charlet
Options

exp_ch7.adb, [...]: Minor reformatting 

2009-04-29  Thomas Quinot  <quinot@adacore.com>

	* exp_ch7.adb, rtsfind.adb: Minor reformatting

	* sem_res.adb: Minor reformatting

From-SVN: r146937
parent 4342eda9
Showing with 167 additions and 152 deletions
gcc/ada/ChangeLog
2009-04-29 Thomas Quinot <quinot@adacore.com> 2009-04-29 Thomas Quinot <quinot@adacore.com>
* exp_ch7.adb, rtsfind.adb: Minor reformatting
* sem_res.adb: Minor reformatting
2009-04-29 Thomas Quinot <quinot@adacore.com>
* sem_res.adb (Static_Concatenation): An N_Op_Concat with static * sem_res.adb (Static_Concatenation): An N_Op_Concat with static
operands is static only if it is a predefined concatenation operator. operands is static only if it is a predefined concatenation operator.
......
gcc/ada/exp_ch7.adb
...@@ -453,7 +453,7 @@ package body Exp_Ch7 is ...@@ -453,7 +453,7 @@ package body Exp_Ch7 is
-- worst-case assumption for runtime files, for efficiency reasons -- worst-case assumption for runtime files, for efficiency reasons
-- (see exp_ch3.adb). The reference to RE_List_Controller may have -- (see exp_ch3.adb). The reference to RE_List_Controller may have
-- added a with_clause to the current body. Formally the spec needs -- added a with_clause to the current body. Formally the spec needs
-- the with_clause as well, so we add it now, for use by codepeer. -- the with_clause as well, so we add it now, for use by Codepeer.
declare declare
Loc : constant Source_Ptr := Sloc (Typ); Loc : constant Source_Ptr := Sloc (Typ);
......
gcc/ada/rtsfind.adb
...@@ -1445,9 +1445,7 @@ package body Rtsfind is ...@@ -1445,9 +1445,7 @@ package body Rtsfind is
goto Continue; goto Continue;
end if; end if;
Load_RTU Load_RTU (To_Load, Use_Setting => In_Use (Cunit_Entity (U)));
(To_Load,
Use_Setting => In_Use (Cunit_Entity (U)));
Set_Is_Visible_Child_Unit (RT_Unit_Table (To_Load).Entity); Set_Is_Visible_Child_Unit (RT_Unit_Table (To_Load).Entity);
-- Prevent creation of an implicit 'with' from (for example) -- Prevent creation of an implicit 'with' from (for example)
......
gcc/ada/sem_res.adb
...@@ -3030,7 +3030,8 @@ package body Sem_Res is ...@@ -3030,7 +3030,8 @@ package body Sem_Res is
when N_String_Literal => when N_String_Literal =>
return True; return True;
when N_Op_Concat => when N_Op_Concat =>
-- Concatenation is static when both operands are static -- Concatenation is static when both operands are static
-- and the concatenation operator is a predefined one. -- and the concatenation operator is a predefined one.
...@@ -3047,8 +3048,8 @@ package body Sem_Res is ...@@ -3047,8 +3048,8 @@ package body Sem_Res is
begin begin
return Ekind (Ent) = E_Constant return Ekind (Ent) = E_Constant
and then Present (Constant_Value (Ent)) and then Present (Constant_Value (Ent))
and then Is_Static_Expression and then
(Constant_Value (Ent)); Is_Static_Expression (Constant_Value (Ent));
end; end;
else else
...@@ -3072,9 +3073,9 @@ package body Sem_Res is ...@@ -3072,9 +3073,9 @@ package body Sem_Res is
if No (A) and then Needs_No_Actuals (Nam) then if No (A) and then Needs_No_Actuals (Nam) then
null; null;
-- If we have an error in any actual or formal, indicated by -- If we have an error in any actual or formal, indicated by a type
-- a type of Any_Type, then abandon resolution attempt, and -- of Any_Type, then abandon resolution attempt, and set result type
-- set result type to Any_Type. -- to Any_Type.
elsif (Present (A) and then Etype (A) = Any_Type) elsif (Present (A) and then Etype (A) = Any_Type)
or else Etype (F) = Any_Type or else Etype (F) = Any_Type
...@@ -3150,9 +3151,9 @@ package body Sem_Res is ...@@ -3150,9 +3151,9 @@ package body Sem_Res is
-- aliased, or neither (4.6 (8)). -- aliased, or neither (4.6 (8)).
-- The additional rule 4.6 (24.9.2) seems unduly -- The additional rule 4.6 (24.9.2) seems unduly
-- restrictive: the privacy requirement should not -- restrictive: the privacy requirement should not apply
-- apply to generic types, and should be checked in -- to generic types, and should be checked in an
-- an instance. ARG query is in order. -- instance. ARG query is in order ???
Error_Msg_N Error_Msg_N
("both component types in a view conversion must be" ("both component types in a view conversion must be"
...@@ -3567,7 +3568,7 @@ package body Sem_Res is ...@@ -3567,7 +3568,7 @@ package body Sem_Res is
end if; end if;
-- Check that subprograms don't have improper controlling -- Check that subprograms don't have improper controlling
-- arguments (RM 3.9.2 (9)) -- arguments (RM 3.9.2 (9)).
-- A primitive operation may have an access parameter of an -- A primitive operation may have an access parameter of an
-- incomplete tagged type, but a dispatching call is illegal -- incomplete tagged type, but a dispatching call is illegal
...@@ -4746,7 +4747,11 @@ package body Sem_Res is ...@@ -4746,7 +4747,11 @@ package body Sem_Res is
else else
pragma Assert (Is_Overloaded (Subp)); pragma Assert (Is_Overloaded (Subp));
Nam := Empty; -- We know that it will be assigned in loop below
-- Initialize Nam to prevent warning (we know it will be assigned
-- in the loop below, but the compiler does not know that).
Nam := Empty;
Get_First_Interp (Subp, I, It); Get_First_Interp (Subp, I, It);
while Present (It.Typ) loop while Present (It.Typ) loop
...@@ -5191,9 +5196,9 @@ package body Sem_Res is ...@@ -5191,9 +5196,9 @@ package body Sem_Res is
if Present (First_Formal (Nam)) then if Present (First_Formal (Nam)) then
Resolve_Actuals (N, Nam); Resolve_Actuals (N, Nam);
-- Overloaded literals are rewritten as function calls, for -- Overloaded literals are rewritten as function calls, for purpose of
-- purpose of resolution. After resolution, we can replace -- resolution. After resolution, we can replace the call with the
-- the call with the literal itself. -- literal itself.
elsif Ekind (Nam) = E_Enumeration_Literal then elsif Ekind (Nam) = E_Enumeration_Literal then
Copy_Node (Subp, N); Copy_Node (Subp, N);
...@@ -5256,7 +5261,8 @@ package body Sem_Res is ...@@ -5256,7 +5261,8 @@ package body Sem_Res is
A := First_Actual (N); A := First_Actual (N);
while Present (F) and then Present (A) loop while Present (F) and then Present (A) loop
if (Ekind (F) = E_Out_Parameter if (Ekind (F) = E_Out_Parameter
or else Ekind (F) = E_In_Out_Parameter) or else
Ekind (F) = E_In_Out_Parameter)
and then Warn_On_Modified_As_Out_Parameter (F) and then Warn_On_Modified_As_Out_Parameter (F)
and then Is_Entity_Name (A) and then Is_Entity_Name (A)
and then Present (Entity (A)) and then Present (Entity (A))
...@@ -5379,14 +5385,14 @@ package body Sem_Res is ...@@ -5379,14 +5385,14 @@ package body Sem_Res is
elsif Root_Type (B_Typ) = Standard_Wide_Wide_Character then elsif Root_Type (B_Typ) = Standard_Wide_Wide_Character then
return; return;
-- If the entity is already set, this has already been resolved in -- If the entity is already set, this has already been resolved in a
-- a generic context, or comes from expansion. Nothing else to do. -- generic context, or comes from expansion. Nothing else to do.
elsif Present (Entity (N)) then elsif Present (Entity (N)) then
return; return;
-- Otherwise we have a user defined character type, and we can use -- Otherwise we have a user defined character type, and we can use the
-- the standard visibility mechanisms to locate the referenced entity -- standard visibility mechanisms to locate the referenced entity.
else else
C := Current_Entity (N); C := Current_Entity (N);
...@@ -5424,10 +5430,10 @@ package body Sem_Res is ...@@ -5424,10 +5430,10 @@ package body Sem_Res is
T : Entity_Id; T : Entity_Id;
begin begin
-- If this is an intrinsic operation which is not predefined, use -- If this is an intrinsic operation which is not predefined, use the
-- the types of its declared arguments to resolve the possibly -- types of its declared arguments to resolve the possibly overloaded
-- overloaded operands. Otherwise the operands are unambiguous and -- operands. Otherwise the operands are unambiguous and specify the
-- specify the expected type. -- expected type.
if Scope (Entity (N)) /= Standard_Standard then if Scope (Entity (N)) /= Standard_Standard then
T := Etype (First_Entity (Entity (N))); T := Etype (First_Entity (Entity (N)));
...@@ -5444,9 +5450,9 @@ package body Sem_Res is ...@@ -5444,9 +5450,9 @@ package body Sem_Res is
Generate_Reference (T, N, ' '); Generate_Reference (T, N, ' ');
if T /= Any_Type then if T /= Any_Type then
if T = Any_String if T = Any_String or else
or else T = Any_Composite T = Any_Composite or else
or else T = Any_Character T = Any_Character
then then
if T = Any_Character then if T = Any_Character then
Ambiguous_Character (L); Ambiguous_Character (L);
...@@ -5477,12 +5483,10 @@ package body Sem_Res is ...@@ -5477,12 +5483,10 @@ package body Sem_Res is
Condition : constant Node_Id := First (Expressions (N)); Condition : constant Node_Id := First (Expressions (N));
Then_Expr : constant Node_Id := Next (Condition); Then_Expr : constant Node_Id := Next (Condition);
Else_Expr : constant Node_Id := Next (Then_Expr); Else_Expr : constant Node_Id := Next (Then_Expr);
begin begin
Resolve (Condition, Standard_Boolean); Resolve (Condition, Standard_Boolean);
Resolve (Then_Expr, Typ); Resolve (Then_Expr, Typ);
Resolve (Else_Expr, Typ); Resolve (Else_Expr, Typ);
Set_Etype (N, Typ); Set_Etype (N, Typ);
Eval_Conditional_Expression (N); Eval_Conditional_Expression (N);
end Resolve_Conditional_Expression; end Resolve_Conditional_Expression;
...@@ -5608,9 +5612,9 @@ package body Sem_Res is ...@@ -5608,9 +5612,9 @@ package body Sem_Res is
Eval_Named_Real (N); Eval_Named_Real (N);
-- Allow use of subtype only if it is a concurrent type where we are -- Allow use of subtype only if it is a concurrent type where we are
-- currently inside the body. This will eventually be expanded -- currently inside the body. This will eventually be expanded into a
-- into a call to Self (for tasks) or _object (for protected -- call to Self (for tasks) or _object (for protected objects). Any
-- objects). Any other use of a subtype is invalid. -- other use of a subtype is invalid.
elsif Is_Type (E) then elsif Is_Type (E) then
if Is_Concurrent_Type (E) if Is_Concurrent_Type (E)
...@@ -5650,9 +5654,9 @@ package body Sem_Res is ...@@ -5650,9 +5654,9 @@ package body Sem_Res is
-- In all other cases, just do the possible static evaluation -- In all other cases, just do the possible static evaluation
else else
-- A deferred constant that appears in an expression must have -- A deferred constant that appears in an expression must have a
-- a completion, unless it has been removed by in-place expansion -- completion, unless it has been removed by in-place expansion of
-- of an aggregate. -- an aggregate.
if Ekind (E) = E_Constant if Ekind (E) = E_Constant
and then Comes_From_Source (E) and then Comes_From_Source (E)
...@@ -5709,11 +5713,11 @@ package body Sem_Res is ...@@ -5709,11 +5713,11 @@ package body Sem_Res is
function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id; function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
-- If the bound is given by a discriminant, replace with a reference -- If the bound is given by a discriminant, replace with a reference
-- to the discriminant of the same name in the target task. -- to the discriminant of the same name in the target task. If the
-- If the entry name is the target of a requeue statement and the -- entry name is the target of a requeue statement and the entry is
-- entry is in the current protected object, the bound to be used -- in the current protected object, the bound to be used is the
-- is the discriminal of the object (see apply_range_checks for -- discriminal of the object (see apply_range_checks for details of
-- details of the transformation). -- the transformation).
----------------------------- -----------------------------
-- Actual_Discriminant_Ref -- -- Actual_Discriminant_Ref --
...@@ -5753,7 +5757,8 @@ package body Sem_Res is ...@@ -5753,7 +5757,8 @@ package body Sem_Res is
begin begin
if not Has_Discriminants (Tsk) if not Has_Discriminants (Tsk)
or else (not Is_Entity_Name (Lo) or else (not Is_Entity_Name (Lo)
and then not Is_Entity_Name (Hi)) and then
not Is_Entity_Name (Hi))
then then
return Entry_Index_Type (E); return Entry_Index_Type (E);
...@@ -5789,23 +5794,23 @@ package body Sem_Res is ...@@ -5789,23 +5794,23 @@ package body Sem_Res is
end if; end if;
if Is_Entity_Name (E_Name) then if Is_Entity_Name (E_Name) then
-- Entry call to an entry (or entry family) in the current task.
-- This is legal even though the task will deadlock. Rewrite as
-- call to current task.
-- This can also be a call to an entry in an enclosing task. -- Entry call to an entry (or entry family) in the current task. This
-- If this is a single task, we have to retrieve its name, -- is legal even though the task will deadlock. Rewrite as call to
-- because the scope of the entry is the task type, not the -- current task.
-- object. If the enclosing task is a task type, the identity
-- of the task is given by its own self variable.
-- Finally this can be a requeue on an entry of the same task -- This can also be a call to an entry in an enclosing task. If this
-- or protected object. -- is a single task, we have to retrieve its name, because the scope
-- of the entry is the task type, not the object. If the enclosing
-- task is a task type, the identity of the task is given by its own
-- self variable.
-- Finally this can be a requeue on an entry of the same task or
-- protected object.
S := Scope (Entity (E_Name)); S := Scope (Entity (E_Name));
for J in reverse 0 .. Scope_Stack.Last loop for J in reverse 0 .. Scope_Stack.Last loop
if Is_Task_Type (Scope_Stack.Table (J).Entity) if Is_Task_Type (Scope_Stack.Table (J).Entity)
and then not Comes_From_Source (S) and then not Comes_From_Source (S)
then then
...@@ -5842,9 +5847,9 @@ package body Sem_Res is ...@@ -5842,9 +5847,9 @@ package body Sem_Res is
elsif Nkind (Entry_Name) = N_Selected_Component elsif Nkind (Entry_Name) = N_Selected_Component
and then Is_Overloaded (Prefix (Entry_Name)) and then Is_Overloaded (Prefix (Entry_Name))
then then
-- Use the entry name (which must be unique at this point) to -- Use the entry name (which must be unique at this point) to find
-- find the prefix that returns the corresponding task type or -- the prefix that returns the corresponding task type or protected
-- protected type. -- type.
declare declare
Pref : constant Node_Id := Prefix (Entry_Name); Pref : constant Node_Id := Prefix (Entry_Name);
...@@ -5874,8 +5879,8 @@ package body Sem_Res is ...@@ -5874,8 +5879,8 @@ package body Sem_Res is
Index := First (Expressions (Entry_Name)); Index := First (Expressions (Entry_Name));
Resolve (Index, Entry_Index_Type (Nam)); Resolve (Index, Entry_Index_Type (Nam));
-- Up to this point the expression could have been the actual -- Up to this point the expression could have been the actual in a
-- in a simple entry call, and be given by a named association. -- simple entry call, and be given by a named association.
if Nkind (Index) = N_Parameter_Association then if Nkind (Index) = N_Parameter_Association then
Error_Msg_N ("expect expression for entry index", Index); Error_Msg_N ("expect expression for entry index", Index);
...@@ -5900,8 +5905,8 @@ package body Sem_Res is ...@@ -5900,8 +5905,8 @@ package body Sem_Res is
Was_Over : Boolean; Was_Over : Boolean;
begin begin
-- We kill all checks here, because it does not seem worth the -- We kill all checks here, because it does not seem worth the effort to
-- effort to do anything better, an entry call is a big operation. -- do anything better, an entry call is a big operation.
Kill_All_Checks; Kill_All_Checks;
...@@ -6041,17 +6046,17 @@ package body Sem_Res is ...@@ -6041,17 +6046,17 @@ package body Sem_Res is
end if; end if;
end if; end if;
-- After resolution, entry calls and protected procedure calls -- After resolution, entry calls and protected procedure calls are
-- are changed into entry calls, for expansion. The structure -- changed into entry calls, for expansion. The structure of the node
-- of the node does not change, so it can safely be done in place. -- does not change, so it can safely be done in place. Protected
-- Protected function calls must keep their structure because they -- function calls must keep their structure because they are
-- are subexpressions. -- subexpressions.
if Ekind (Nam) /= E_Function then if Ekind (Nam) /= E_Function then
-- A protected operation that is not a function may modify the -- A protected operation that is not a function may modify the
-- corresponding object, and cannot apply to a constant. -- corresponding object, and cannot apply to a constant. If this
-- If this is an internal call, the prefix is the type itself. -- is an internal call, the prefix is the type itself.
if Is_Protected_Type (Scope (Nam)) if Is_Protected_Type (Scope (Nam))
and then not Is_Variable (Obj) and then not Is_Variable (Obj)
...@@ -6088,13 +6093,12 @@ package body Sem_Res is ...@@ -6088,13 +6093,12 @@ package body Sem_Res is
-- Resolve_Equality_Op -- -- Resolve_Equality_Op --
------------------------- -------------------------
-- Both arguments must have the same type, and the boolean context -- Both arguments must have the same type, and the boolean context does
-- does not participate in the resolution. The first pass verifies -- not participate in the resolution. The first pass verifies that the
-- that the interpretation is not ambiguous, and the type of the left -- interpretation is not ambiguous, and the type of the left argument is
-- argument is correctly set, or is Any_Type in case of ambiguity. -- correctly set, or is Any_Type in case of ambiguity. If both arguments
-- If both arguments are strings or aggregates, allocators, or Null, -- are strings or aggregates, allocators, or Null, they are ambiguous even
-- they are ambiguous even though they carry a single (universal) type. -- though they carry a single (universal) type. Diagnose this case here.
-- Diagnose this case here.
procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id) is procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id) is
L : constant Node_Id := Left_Opnd (N); L : constant Node_Id := Left_Opnd (N);
...@@ -6227,13 +6231,13 @@ package body Sem_Res is ...@@ -6227,13 +6231,13 @@ package body Sem_Res is
Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N)); Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N));
end if; end if;
-- Ada 2005: If one operand is an anonymous access type, convert -- Ada 2005: If one operand is an anonymous access type, convert the
-- the other operand to it, to ensure that the underlying types -- other operand to it, to ensure that the underlying types match in
-- match in the back-end. Same for access_to_subprogram, and the -- the back-end. Same for access_to_subprogram, and the conversion
-- conversion verifies that the types are subtype conformant. -- verifies that the types are subtype conformant.
-- We apply the same conversion in the case one of the operands is -- We apply the same conversion in the case one of the operands is a
-- a private subtype of the type of the other. -- private subtype of the type of the other.
-- Why the Expander_Active test here ??? -- Why the Expander_Active test here ???
...@@ -6533,8 +6537,8 @@ package body Sem_Res is ...@@ -6533,8 +6537,8 @@ package body Sem_Res is
elsif Typ /= Etype (Left_Opnd (N)) elsif Typ /= Etype (Left_Opnd (N))
or else Typ /= Etype (Right_Opnd (N)) or else Typ /= Etype (Right_Opnd (N))
then then
-- Add explicit conversion where needed, and save interpretations -- Add explicit conversion where needed, and save interpretations in
-- in case operands are overloaded. -- case operands are overloaded.
Arg1 := Convert_To (Typ, Left_Opnd (N)); Arg1 := Convert_To (Typ, Left_Opnd (N));
Arg2 := Convert_To (Typ, Right_Opnd (N)); Arg2 := Convert_To (Typ, Right_Opnd (N));
...@@ -6688,7 +6692,7 @@ package body Sem_Res is ...@@ -6688,7 +6692,7 @@ package body Sem_Res is
then then
T := Etype (R); T := Etype (R);
-- Ada 2005 (AI-251): Give support to the following case: -- Ada 2005 (AI-251): Support the following case:
-- type I is interface; -- type I is interface;
-- type T is tagged ... -- type T is tagged ...
...@@ -6698,7 +6702,7 @@ package body Sem_Res is ...@@ -6698,7 +6702,7 @@ package body Sem_Res is
-- return O in T'Class. -- return O in T'Class.
-- end Test; -- end Test;
-- In this case we have nothing else to do; the membership test will be -- In this case we have nothing else to do. The membership test will be
-- done at run-time. -- done at run-time.
elsif Ada_Version >= Ada_05 elsif Ada_Version >= Ada_05
...@@ -6750,8 +6754,8 @@ package body Sem_Res is ...@@ -6750,8 +6754,8 @@ package body Sem_Res is
and then Ekind (Typ) = E_Anonymous_Access_Type and then Ekind (Typ) = E_Anonymous_Access_Type
and then Comes_From_Source (N) and then Comes_From_Source (N)
then then
-- In the common case of a call which uses an explicitly null -- In the common case of a call which uses an explicitly null value
-- value for an access parameter, give specialized error message. -- for an access parameter, give specialized error message.
if Nkind_In (Parent (N), N_Procedure_Call_Statement, if Nkind_In (Parent (N), N_Procedure_Call_Statement,
N_Function_Call) N_Function_Call)
...@@ -6787,9 +6791,9 @@ package body Sem_Res is ...@@ -6787,9 +6791,9 @@ package body Sem_Res is
end if; end if;
end if; end if;
-- In a distributed context, null for a remote access to subprogram -- In a distributed context, null for a remote access to subprogram may
-- may need to be replaced with a special record aggregate. In this -- need to be replaced with a special record aggregate. In this case,
-- case, return after having done the transformation. -- return after having done the transformation.
if (Ekind (Typ) = E_Record_Type if (Ekind (Typ) = E_Record_Type
or else Is_Remote_Access_To_Subprogram_Type (Typ)) or else Is_Remote_Access_To_Subprogram_Type (Typ))
...@@ -6816,7 +6820,7 @@ package body Sem_Res is ...@@ -6816,7 +6820,7 @@ package body Sem_Res is
-- up the tree following Parent pointers, calling Resolve_Op_Concat_Rest -- up the tree following Parent pointers, calling Resolve_Op_Concat_Rest
-- to do the rest of the work at each level. The Parent pointers allow -- to do the rest of the work at each level. The Parent pointers allow
-- us to avoid recursion, and thus avoid running out of memory. See also -- us to avoid recursion, and thus avoid running out of memory. See also
-- Sem_Ch4.Analyze_Concatenation, where a similar hack is used. -- Sem_Ch4.Analyze_Concatenation, where a similar approach is used.
NN : Node_Id := N; NN : Node_Id := N;
Op1 : Node_Id; Op1 : Node_Id;
...@@ -7012,9 +7016,9 @@ package body Sem_Res is ...@@ -7012,9 +7016,9 @@ package body Sem_Res is
Eval_Concatenation (N); Eval_Concatenation (N);
end if; end if;
-- If this is not a static concatenation, but the result is a -- If this is not a static concatenation, but the result is a string
-- string type (and not an array of strings) ensure that static -- type (and not an array of strings) ensure that static string operands
-- string operands have their subtypes properly constructed. -- have their subtypes properly constructed.
if Nkind (N) /= N_String_Literal if Nkind (N) /= N_String_Literal
and then Is_Character_Type (Component_Type (Typ)) and then Is_Character_Type (Component_Type (Typ))
...@@ -7722,8 +7726,8 @@ package body Sem_Res is ...@@ -7722,8 +7726,8 @@ package body Sem_Res is
begin begin
if Is_Overloaded (Name) then if Is_Overloaded (Name) then
-- Use the context type to select the prefix that yields the -- Use the context type to select the prefix that yields the correct
-- correct array type. -- array type.
declare declare
I : Interp_Index; I : Interp_Index;
...@@ -7896,8 +7900,8 @@ package body Sem_Res is ...@@ -7896,8 +7900,8 @@ package body Sem_Res is
or else Typ = Standard_Wide_Wide_String) or else Typ = Standard_Wide_Wide_String)
and then Nkind (Original_Node (N)) /= N_String_Literal); and then Nkind (Original_Node (N)) /= N_String_Literal);
-- If the resolving type is itself a string literal subtype, we -- If the resolving type is itself a string literal subtype, we can just
-- can just reuse it, since there is no point in creating another. -- reuse it, since there is no point in creating another.
if Ekind (Typ) = E_String_Literal_Subtype then if Ekind (Typ) = E_String_Literal_Subtype then
Subtype_Id := Typ; Subtype_Id := Typ;
...@@ -7935,8 +7939,8 @@ package body Sem_Res is ...@@ -7935,8 +7939,8 @@ package body Sem_Res is
return; return;
end if; end if;
-- The validity of a null string has been checked in the -- The validity of a null string has been checked in the call to
-- call to Eval_String_Literal. -- Eval_String_Literal.
if Strlen = 0 then if Strlen = 0 then
return; return;
...@@ -7982,7 +7986,9 @@ package body Sem_Res is ...@@ -7982,7 +7986,9 @@ package body Sem_Res is
-- If we are out of range, post error. This is one of the -- If we are out of range, post error. This is one of the
-- very few places that we place the flag in the middle of -- very few places that we place the flag in the middle of
-- a token, right under the offending wide character. -- a token, right under the offending wide character. Not
-- quite clear if this is right wrt wide character encoding
-- sequences, but it's only an error message!
Error_Msg Error_Msg
("literal out of range of type Standard.Character", ("literal out of range of type Standard.Character",
...@@ -8214,26 +8220,26 @@ package body Sem_Res is ...@@ -8214,26 +8220,26 @@ package body Sem_Res is
Resolve (Operand); Resolve (Operand);
-- Note: we do the Eval_Type_Conversion call before applying the -- Note: we do the Eval_Type_Conversion call before applying the
-- required checks for a subtype conversion. This is important, -- required checks for a subtype conversion. This is important, since
-- since both are prepared under certain circumstances to change -- both are prepared under certain circumstances to change the type
-- the type conversion to a constraint error node, but in the case -- conversion to a constraint error node, but in the case of
-- of Eval_Type_Conversion this may reflect an illegality in the -- Eval_Type_Conversion this may reflect an illegality in the static
-- static case, and we would miss the illegality (getting only a -- case, and we would miss the illegality (getting only a warning
-- warning message), if we applied the type conversion checks first. -- message), if we applied the type conversion checks first.
Eval_Type_Conversion (N); Eval_Type_Conversion (N);
-- Even when evaluation is not possible, we may be able to simplify -- Even when evaluation is not possible, we may be able to simplify the
-- the conversion or its expression. This needs to be done before -- conversion or its expression. This needs to be done before applying
-- applying checks, since otherwise the checks may use the original -- checks, since otherwise the checks may use the original expression
-- expression and defeat the simplifications. This is specifically -- and defeat the simplifications. This is specifically the case for
-- the case for elimination of the floating-point Truncation -- elimination of the floating-point Truncation attribute in
-- attribute in float-to-int conversions. -- float-to-int conversions.
Simplify_Type_Conversion (N); Simplify_Type_Conversion (N);
-- If after evaluation we still have a type conversion, then we -- If after evaluation we still have a type conversion, then we may need
-- may need to apply checks required for a subtype conversion. -- to apply checks required for a subtype conversion.
-- Skip these type conversion checks if universal fixed operands -- Skip these type conversion checks if universal fixed operands
-- operands involved, since range checks are handled separately for -- operands involved, since range checks are handled separately for
...@@ -8247,9 +8253,9 @@ package body Sem_Res is ...@@ -8247,9 +8253,9 @@ package body Sem_Res is
Apply_Type_Conversion_Checks (N); Apply_Type_Conversion_Checks (N);
end if; end if;
-- Issue warning for conversion of simple object to its own type -- Issue warning for conversion of simple object to its own type. We
-- We have to test the original nodes, since they may have been -- have to test the original nodes, since they may have been rewritten
-- rewritten by various optimizations. -- by various optimizations.
Orig_N := Original_Node (N); Orig_N := Original_Node (N);
...@@ -8443,9 +8449,9 @@ package body Sem_Res is ...@@ -8443,9 +8449,9 @@ package body Sem_Res is
end if; end if;
end if; end if;
-- Generate warning for expressions like -5 mod 3 for integers. No -- Generate warning for expressions like -5 mod 3 for integers. No need
-- need to worry in the floating-point case, since parens do not affect -- to worry in the floating-point case, since parens do not affect the
-- the result so there is no point in giving in a warning. -- result so there is no point in giving in a warning.
declare declare
Norig : constant Node_Id := Original_Node (N); Norig : constant Node_Id := Original_Node (N);
...@@ -8473,7 +8479,7 @@ package body Sem_Res is ...@@ -8473,7 +8479,7 @@ package body Sem_Res is
then then
-- For mod, we always give the warning, since the value is -- For mod, we always give the warning, since the value is
-- affected by the parenthesization (e.g. (-5) mod 315 /= -- affected by the parenthesization (e.g. (-5) mod 315 /=
-- (5 mod 315)). But for the other cases, the only concern is -- -(5 mod 315)). But for the other cases, the only concern is
-- overflow, e.g. for the case of 8 big signed (-(2 * 64) -- overflow, e.g. for the case of 8 big signed (-(2 * 64)
-- overflows, but (-2) * 64 does not). So we try to give the -- overflows, but (-2) * 64 does not). So we try to give the
-- message only when overflow is possible. -- message only when overflow is possible.
...@@ -8495,8 +8501,8 @@ package body Sem_Res is ...@@ -8495,8 +8501,8 @@ package body Sem_Res is
LB := Expr_Value (Type_Low_Bound (Base_Type (Typ))); LB := Expr_Value (Type_Low_Bound (Base_Type (Typ)));
end if; end if;
-- Note that the test below is deliberately excluding -- Note that the test below is deliberately excluding the
-- the largest negative number, since that is a potentially -- largest negative number, since that is a potentially
-- troublesome case (e.g. -2 * x, where the result is the -- troublesome case (e.g. -2 * x, where the result is the
-- largest negative integer has an overflow with 2 * x). -- largest negative integer has an overflow with 2 * x).
...@@ -8642,9 +8648,9 @@ package body Sem_Res is ...@@ -8642,9 +8648,9 @@ package body Sem_Res is
Op_Node : Node_Id; Op_Node : Node_Id;
begin begin
-- Rewrite the operator node using the real operator, not its -- Rewrite the operator node using the real operator, not its renaming.
-- renaming. Exclude user-defined intrinsic operations of the same -- Exclude user-defined intrinsic operations of the same name, which are
-- name, which are treated separately and rewritten as calls. -- treated separately and rewritten as calls.
if Ekind (Op) /= E_Function if Ekind (Op) /= E_Function
or else Chars (N) /= Nam or else Chars (N) /= Nam
...@@ -8679,7 +8685,7 @@ package body Sem_Res is ...@@ -8679,7 +8685,7 @@ package body Sem_Res is
N_Op_Expon | N_Op_Mod | N_Op_Rem => N_Op_Expon | N_Op_Mod | N_Op_Rem =>
Resolve_Intrinsic_Operator (N, Typ); Resolve_Intrinsic_Operator (N, Typ);
when N_Op_Plus | N_Op_Minus | N_Op_Abs => when N_Op_Plus | N_Op_Minus | N_Op_Abs =>
Resolve_Intrinsic_Unary_Operator (N, Typ); Resolve_Intrinsic_Unary_Operator (N, Typ);
when others => when others =>
...@@ -8783,7 +8789,7 @@ package body Sem_Res is ...@@ -8783,7 +8789,7 @@ package body Sem_Res is
procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id) is procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Low_Bound : constant Node_Id := Low_Bound : constant Node_Id :=
Type_Low_Bound (Etype (First_Index (Typ))); Type_Low_Bound (Etype (First_Index (Typ)));
Subtype_Id : Entity_Id; Subtype_Id : Entity_Id;
begin begin
...@@ -8918,7 +8924,8 @@ package body Sem_Res is ...@@ -8918,7 +8924,8 @@ package body Sem_Res is
Scop : Entity_Id; Scop : Entity_Id;
procedure Fixed_Point_Error; procedure Fixed_Point_Error;
-- If true ambiguity, give details -- Give error messages for true ambiguity. Messages are posted on node
-- N, and entities T1, T2 are the possible interpretations.
----------------------- -----------------------
-- Fixed_Point_Error -- -- Fixed_Point_Error --
...@@ -9247,8 +9254,8 @@ package body Sem_Res is ...@@ -9247,8 +9254,8 @@ package body Sem_Res is
N1 : Entity_Id; N1 : Entity_Id;
begin begin
-- Remove procedure calls, which syntactically cannot appear -- Remove procedure calls, which syntactically cannot appear in
-- in this context, but which cannot be removed by type checking, -- this context, but which cannot be removed by type checking,
-- because the context does not impose a type. -- because the context does not impose a type.
-- When compiling for VMS, spurious ambiguities can be produced -- When compiling for VMS, spurious ambiguities can be produced
...@@ -9376,8 +9383,8 @@ package body Sem_Res is ...@@ -9376,8 +9383,8 @@ package body Sem_Res is
and then Is_Interface (Directly_Designated_Type (Target_Type)) and then Is_Interface (Directly_Designated_Type (Target_Type))
then then
-- Check the static accessibility rule of 4.6(17). Note that the -- Check the static accessibility rule of 4.6(17). Note that the
-- check is not enforced when within an instance body, since the RM -- check is not enforced when within an instance body, since the
-- requires such cases to be caught at run time. -- RM requires such cases to be caught at run time.
if Ekind (Target_Type) /= E_Anonymous_Access_Type then if Ekind (Target_Type) /= E_Anonymous_Access_Type then
if Type_Access_Level (Opnd_Type) > if Type_Access_Level (Opnd_Type) >
...@@ -9408,16 +9415,16 @@ package body Sem_Res is ...@@ -9408,16 +9415,16 @@ package body Sem_Res is
then then
-- When the operand is a selected access discriminant the check -- When the operand is a selected access discriminant the check
-- needs to be made against the level of the object denoted by -- needs to be made against the level of the object denoted by
-- the prefix of the selected name. (Object_Access_Level -- the prefix of the selected name (Object_Access_Level handles
-- handles checking the prefix of the operand for this case.) -- checking the prefix of the operand for this case).
if Nkind (Operand) = N_Selected_Component if Nkind (Operand) = N_Selected_Component
and then Object_Access_Level (Operand) > and then Object_Access_Level (Operand) >
Type_Access_Level (Target_Type) Type_Access_Level (Target_Type)
then then
-- In an instance, this is a run-time check, but one we -- In an instance, this is a run-time check, but one we know
-- know will fail, so generate an appropriate warning. -- will fail, so generate an appropriate warning. The raise
-- The raise will be generated by Expand_N_Type_Conversion. -- will be generated by Expand_N_Type_Conversion.
if In_Instance_Body then if In_Instance_Body then
Error_Msg_N Error_Msg_N
...@@ -9486,9 +9493,9 @@ package body Sem_Res is ...@@ -9486,9 +9493,9 @@ package body Sem_Res is
if Type_Access_Level (Opnd_Type) if Type_Access_Level (Opnd_Type)
> Type_Access_Level (Target_Type) > Type_Access_Level (Target_Type)
then then
-- In an instance, this is a run-time check, but one we -- In an instance, this is a run-time check, but one we know
-- know will fail, so generate an appropriate warning. -- will fail, so generate an appropriate warning. The raise
-- The raise will be generated by Expand_N_Type_Conversion. -- will be generated by Expand_N_Type_Conversion.
if In_Instance_Body then if In_Instance_Body then
Error_Msg_N Error_Msg_N
...@@ -9518,16 +9525,16 @@ package body Sem_Res is ...@@ -9518,16 +9525,16 @@ package body Sem_Res is
-- When the operand is a selected access discriminant the check -- When the operand is a selected access discriminant the check
-- needs to be made against the level of the object denoted by -- needs to be made against the level of the object denoted by
-- the prefix of the selected name. (Object_Access_Level -- the prefix of the selected name (Object_Access_Level handles
-- handles checking the prefix of the operand for this case.) -- checking the prefix of the operand for this case).
if Nkind (Operand) = N_Selected_Component if Nkind (Operand) = N_Selected_Component
and then Object_Access_Level (Operand) > and then Object_Access_Level (Operand) >
Type_Access_Level (Target_Type) Type_Access_Level (Target_Type)
then then
-- In an instance, this is a run-time check, but one we -- In an instance, this is a run-time check, but one we know
-- know will fail, so generate an appropriate warning. -- will fail, so generate an appropriate warning. The raise
-- The raise will be generated by Expand_N_Type_Conversion. -- will be generated by Expand_N_Type_Conversion.
if In_Instance_Body then if In_Instance_Body then
Error_Msg_N Error_Msg_N
...@@ -9564,6 +9571,8 @@ package body Sem_Res is ...@@ -9564,6 +9571,8 @@ package body Sem_Res is
end if; end if;
end if; end if;
-- Need some comments here, and a name for this block ???
declare declare
function Full_Designated_Type (T : Entity_Id) return Entity_Id; function Full_Designated_Type (T : Entity_Id) return Entity_Id;
-- Helper function to handle limited views -- Helper function to handle limited views
...@@ -9585,12 +9594,16 @@ package body Sem_Res is ...@@ -9585,12 +9594,16 @@ package body Sem_Res is
end if; end if;
end Full_Designated_Type; end Full_Designated_Type;
-- Local Declarations
Target : constant Entity_Id := Full_Designated_Type (Target_Type); Target : constant Entity_Id := Full_Designated_Type (Target_Type);
Opnd : constant Entity_Id := Full_Designated_Type (Opnd_Type); Opnd : constant Entity_Id := Full_Designated_Type (Opnd_Type);
Same_Base : constant Boolean := Same_Base : constant Boolean :=
Base_Type (Target) = Base_Type (Opnd); Base_Type (Target) = Base_Type (Opnd);
-- Start of processing for ???
begin begin
if Is_Tagged_Type (Target) then if Is_Tagged_Type (Target) then
return Valid_Tagged_Conversion (Target, Opnd); return Valid_Tagged_Conversion (Target, Opnd);
...@@ -9752,8 +9765,8 @@ package body Sem_Res is ...@@ -9752,8 +9765,8 @@ package body Sem_Res is
elsif (In_Instance or In_Inlined_Body) elsif (In_Instance or In_Inlined_Body)
and then and then
Root_Type (Underlying_Type (Target_Type)) = Root_Type (Underlying_Type (Target_Type)) =
Root_Type (Underlying_Type (Opnd_Type)) Root_Type (Underlying_Type (Opnd_Type))
then then
return True; return True;
...@@ -9764,13 +9777,11 @@ package body Sem_Res is ...@@ -9764,13 +9777,11 @@ package body Sem_Res is
then then
Error_Msg_N ("target type must be general access type!", N); Error_Msg_N ("target type must be general access type!", N);
Error_Msg_NE ("add ALL to }!", N, Target_Type); Error_Msg_NE ("add ALL to }!", N, Target_Type);
return False; return False;
else else
Error_Msg_NE ("invalid conversion, not compatible with }", Error_Msg_NE ("invalid conversion, not compatible with }",
N, Opnd_Type); N, Opnd_Type);
return False; return False;
end if; end if;
end Valid_Conversion; end Valid_Conversion;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment