with Sem_Eval; use Sem_Eval;
with Sem_Intr; use Sem_Intr;
with Sem_Util; use Sem_Util;
+with Targparm; use Targparm;
with Sem_Type; use Sem_Type;
with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
-- is only one requires a search over all visible entities, and happens
-- only in very pathological cases (see 6115-006).
- function Valid_Conversion
- (N : Node_Id;
- Target : Entity_Id;
- Operand : Node_Id) return Boolean;
- -- Verify legality rules given in 4.6 (8-23). Target is the target type
- -- of the conversion, which may be an implicit conversion of an actual
- -- parameter to an anonymous access type (in which case N denotes the
- -- actual parameter and N = Operand).
-
-------------------------
-- Ambiguous_Character --
-------------------------
if Nkind (Parent (N)) /= N_Function_Call
or else N /= Name (Parent (N))
then
+
+ -- This may be a prefixed call that was not fully analyzed, e.g.
+ -- an actual in an instance.
+
+ if Ada_Version >= Ada_2005
+ and then Nkind (N) = N_Selected_Component
+ and then Is_Dispatching_Operation (Entity (Selector_Name (N)))
+ then
+ Analyze_Selected_Component (N);
+
+ if Nkind (N) /= N_Selected_Component then
+ return;
+ end if;
+ end if;
+
Nam := New_Copy (N);
-- If overloaded, overload set belongs to new copy
Tsk : Node_Id := Empty;
function Process_Discr (Nod : Node_Id) return Traverse_Result;
+ -- Comment needed???
-------------------
-- Process_Discr --
-- Start of processing for Replace_Actual_Discriminants
begin
- if not Expander_Active then
+ if not Full_Expander_Active then
return;
end if;
procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id) is
begin
- if Nkind (N) = N_Integer_Literal
- and then Is_Real_Type (Typ)
- then
+ if Nkind (N) = N_Integer_Literal and then Is_Real_Type (Typ) then
Rewrite (N,
Make_Real_Literal (Sloc (N),
Realval => UR_From_Uint (Intval (N))));
Set_Etype (N, Universal_Real);
Set_Is_Static_Expression (N);
- elsif Nkind (N) = N_Real_Literal
- and then Is_Integer_Type (Typ)
- then
+ elsif Nkind (N) = N_Real_Literal and then Is_Integer_Type (Typ) then
Rewrite (N,
Make_Integer_Literal (Sloc (N),
Intval => UR_To_Uint (Realval (N))));
Set_Is_Static_Expression (N);
elsif Nkind (N) = N_String_Literal
- and then Is_Character_Type (Typ)
+ and then Is_Character_Type (Typ)
then
Set_Character_Literal_Name (Char_Code (Character'Pos ('A')));
Rewrite (N,
Set_Etype (N, Any_Character);
Set_Is_Static_Expression (N);
- elsif Nkind (N) /= N_String_Literal
- and then Is_String_Type (Typ)
- then
+ elsif Nkind (N) /= N_String_Literal and then Is_String_Type (Typ) then
Rewrite (N,
Make_String_Literal (Sloc (N),
Strval => End_String));
elsif Nkind (N) = N_Range then
- Patch_Up_Value (Low_Bound (N), Typ);
+ Patch_Up_Value (Low_Bound (N), Typ);
Patch_Up_Value (High_Bound (N), Typ);
end if;
end Patch_Up_Value;
then
Error_Msg_NE ("ambiguous call to&", Arg, Name (Arg));
- -- Could use comments on what is going on here ???
+ -- Could use comments on what is going on here???
Get_First_Interp (Name (Arg), I, It);
while Present (It.Nam) loop
return;
end if;
- -- Access attribute on remote subprogram cannot be used for
- -- a non-remote access-to-subprogram type.
+ -- Access attribute on remote subprogram cannot be used for a non-remote
+ -- access-to-subprogram type.
if Nkind (N) = N_Attribute_Reference
and then (Attribute_Name (N) = Name_Access or else
if (Attr = Attribute_Access or else
Attr = Attribute_Unchecked_Access or else
Attr = Attribute_Unrestricted_Access)
- and then Expander_Active
+ and then Full_Expander_Active
and then Get_PCS_Name /= Name_No_DSA
then
Check_Subtype_Conformant
elsif Nkind (N) = N_Conditional_Expression then
Set_Etype (N, Expr_Type);
+ -- AI05-0139-2: Expression is overloaded because type has
+ -- implicit dereference. If type matches context, no implicit
+ -- dereference is involved.
+
+ elsif Has_Implicit_Dereference (Expr_Type) then
+ Set_Etype (N, Expr_Type);
+ Set_Is_Overloaded (N, False);
+ exit Interp_Loop;
+
+ elsif Is_Overloaded (N)
+ and then Present (It.Nam)
+ and then Ekind (It.Nam) = E_Discriminant
+ and then Has_Implicit_Dereference (It.Nam)
+ then
+ Build_Explicit_Dereference (N, It.Nam);
+
-- For an explicit dereference, attribute reference, range,
-- short-circuit form (which is not an operator node), or call
-- with a name that is an explicit dereference, there is
Resolve_Unchecked_Type_Conversion (N, Ctx_Type);
end case;
+ -- Ada 2012 (AI05-0149): Apply an (implicit) conversion to an
+ -- expression of an anonymous access type that occurs in the context
+ -- of a named general access type, except when the expression is that
+ -- of a membership test. This ensures proper legality checking in
+ -- terms of allowed conversions (expressions that would be illegal to
+ -- convert implicitly are allowed in membership tests).
+
+ if Ada_Version >= Ada_2012
+ and then Ekind (Ctx_Type) = E_General_Access_Type
+ and then Ekind (Etype (N)) = E_Anonymous_Access_Type
+ and then Nkind (Parent (N)) not in N_Membership_Test
+ then
+ Rewrite (N, Convert_To (Ctx_Type, Relocate_Node (N)));
+ Analyze_And_Resolve (N, Ctx_Type);
+ end if;
+
-- If the subexpression was replaced by a non-subexpression, then
-- all we do is to expand it. The only legitimate case we know of
-- is converting procedure call statement to entry call statements,
-- default expression mode (the Freeze_Expression routine tests this
-- flag and only freezes static types if it is set).
- Freeze_Expression (N);
+ -- AI05-177 (Ada2012): Expression functions do not freeze. Only
+ -- their use (in an expanded call) freezes.
+
+ if Ekind (Current_Scope) /= E_Function
+ or else
+ Nkind (Original_Node (Unit_Declaration_Node (Current_Scope))) /=
+ N_Expression_Function
+ then
+ Freeze_Expression (N);
+ end if;
-- Now we can do the expansion
elsif Nkind (A) = N_Function_Call
and then Is_Limited_Record (Etype (F))
and then not Is_Constrained (Etype (F))
- and then Expander_Active
+ and then Full_Expander_Active
and then (Is_Controlled (Etype (F)) or else Has_Task (Etype (F)))
then
Establish_Transient_Scope (A, False);
+ Resolve (A, Etype (F));
-- A small optimization: if one of the actuals is a concatenation
-- create a block around a procedure call to recover stack space.
elsif Nkind (A) = N_Op_Concat
and then Nkind (N) = N_Procedure_Call_Statement
- and then Expander_Active
+ and then Full_Expander_Active
and then
not (Is_Intrinsic_Subprogram (Nam)
and then Chars (Nam) = Name_Asm)
-- be removed in the expansion of the wrapped construct.
if (Is_Controlled (DDT) or else Has_Task (DDT))
- and then Expander_Active
+ and then Full_Expander_Active
then
Establish_Transient_Scope (A, False);
end if;
-- Is_OK_Variable_For_Out_Formal generates the required
-- reference in this case.
- if not Is_OK_Variable_For_Out_Formal (A) then
+ -- A call to an initialization procedure for an aggregate
+ -- component may initialize a nested component of a constant
+ -- designated object. In this context the object is variable.
+
+ if not Is_OK_Variable_For_Out_Formal (A)
+ and then not Is_Init_Proc (Nam)
+ then
Error_Msg_NE ("actual for& must be a variable", A, F);
end if;
("& is not a dispatching operation of &!", A, Nam);
end if;
+ -- Apply the checks described in 3.10.2(27): if the context is a
+ -- specific access-to-object, the actual cannot be class-wide.
+ -- Use base type to exclude access_to_subprogram cases.
+
elsif Is_Access_Type (A_Typ)
and then Is_Access_Type (F_Typ)
- and then Ekind (F_Typ) /= E_Access_Subprogram_Type
- and then Ekind (F_Typ) /= E_Anonymous_Access_Subprogram_Type
+ and then not Is_Access_Subprogram_Type (Base_Type (F_Typ))
and then (Is_Class_Wide_Type (Designated_Type (A_Typ))
or else (Nkind (A) = N_Attribute_Reference
and then
- Is_Class_Wide_Type (Etype (Prefix (A)))))
+ Is_Class_Wide_Type (Etype (Prefix (A)))))
and then not Is_Class_Wide_Type (Designated_Type (F_Typ))
and then not Is_Controlling_Formal (F)
Error_Msg_N
("access to class-wide argument not allowed here!", A);
- if Is_Subprogram (Nam)
- and then Comes_From_Source (Nam)
- then
+ if Is_Subprogram (Nam) and then Comes_From_Source (Nam) then
Error_Msg_Node_2 := Designated_Type (F_Typ);
Error_Msg_NE
("& is not a dispatching operation of &!", A, Nam);
Eval_Actual (A);
-- If it is a named association, treat the selector_name as a
- -- proper identifier, and mark the corresponding entity.
+ -- proper identifier, and mark the corresponding entity. Ignore
+ -- this reference in Alfa mode, as it refers to an entity not in
+ -- scope at the point of reference, so the reference should be
+ -- ignored for computing effects of subprograms.
- if Nkind (Parent (A)) = N_Parameter_Association then
+ if Nkind (Parent (A)) = N_Parameter_Association
+ and then not Alfa_Mode
+ then
Set_Entity (Selector_Name (Parent (A)), F);
Generate_Reference (F, Selector_Name (Parent (A)));
Set_Etype (Selector_Name (Parent (A)), F_Typ);
-----------------------
procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id) is
- E : constant Node_Id := Expression (N);
+ Desig_T : constant Entity_Id := Designated_Type (Typ);
+ E : constant Node_Id := Expression (N);
Subtyp : Entity_Id;
Discrim : Entity_Id;
Constr : Node_Id;
if Nkind (E) = N_Qualified_Expression then
if Is_Class_Wide_Type (Etype (E))
- and then not Is_Class_Wide_Type (Designated_Type (Typ))
+ and then not Is_Class_Wide_Type (Desig_T)
and then not In_Dispatching_Context
then
Error_Msg_N
-- Expand_Allocator_Expression).
if Ada_Version >= Ada_2005
- and then Is_Class_Wide_Type (Designated_Type (Typ))
+ and then Is_Class_Wide_Type (Desig_T)
then
declare
Exp_Typ : Entity_Id;
Check_Restriction (No_Anonymous_Allocators, N);
end if;
+ -- Check that an allocator with task parts isn't for a nested access
+ -- type when restriction No_Task_Hierarchy applies.
+
+ if not Is_Library_Level_Entity (Base_Type (Typ))
+ and then Has_Task (Base_Type (Desig_T))
+ then
+ Check_Restriction (No_Task_Hierarchy, N);
+ end if;
+
-- An erroneous allocator may be rewritten as a raise Program_Error
-- statement.
and then Nkind (Associated_Node_For_Itype (Typ)) =
N_Discriminant_Specification
then
+ declare
+ Discr : constant Entity_Id :=
+ Defining_Identifier (Associated_Node_For_Itype (Typ));
+
+ begin
+ -- Ada 2012 AI05-0052: If the designated type of the allocator
+ -- is limited, then the allocator shall not be used to define
+ -- the value of an access discriminant unless the discriminated
+ -- type is immutably limited.
+
+ if Ada_Version >= Ada_2012
+ and then Is_Limited_Type (Desig_T)
+ and then not Is_Immutably_Limited_Type (Scope (Discr))
+ then
+ Error_Msg_N
+ ("only immutably limited types can have anonymous "
+ & "access discriminants designating a limited type", N);
+ end if;
+ end;
+
-- Avoid marking an allocator as a dynamic coextension if it is
-- within a static construct.
Set_Is_Static_Coextension (N, False);
end if;
end if;
+
+ -- Report a simple error: if the designated object is a local task,
+ -- its body has not been seen yet, and its activation will fail an
+ -- elaboration check.
+
+ if Is_Task_Type (Desig_T)
+ and then Scope (Base_Type (Desig_T)) = Current_Scope
+ and then Is_Compilation_Unit (Current_Scope)
+ and then Ekind (Current_Scope) = E_Package
+ and then not In_Package_Body (Current_Scope)
+ then
+ Error_Msg_N ("cannot activate task before body seen?", N);
+ Error_Msg_N ("\Program_Error will be raised at run time?", N);
+ end if;
+
+ -- Ada 2012 (AI05-0111-3): Issue a warning whenever allocating a task
+ -- or a type containing tasks on a subpool since the deallocation of
+ -- the subpool may lead to undefined task behavior. Perform the check
+ -- only when the allocator has not been converted into a Program_Error
+ -- due to a previous error.
+
+ if Ada_Version >= Ada_2012
+ and then Nkind (N) = N_Allocator
+ and then Present (Subpool_Handle_Name (N))
+ and then Has_Task (Desig_T)
+ then
+ Error_Msg_N ("?allocation of task on subpool may lead to " &
+ "undefined behavior", N);
+ end if;
end Resolve_Allocator;
---------------------------
-- universal real, since in this case we don't do a conversion to a
-- specific fixed-point type (instead the expander handles the case).
+ -- Set the type of the node to its universal interpretation because
+ -- legality checks on an exponentiation operand need the context.
+
elsif (B_Typ = Universal_Integer or else B_Typ = Universal_Real)
and then Present (Universal_Interpretation (L))
and then Present (Universal_Interpretation (R))
then
+ Set_Etype (N, B_Typ);
Resolve (L, Universal_Interpretation (L));
Resolve (R, Universal_Interpretation (R));
- Set_Etype (N, B_Typ);
elsif (B_Typ = Universal_Real
or else Etype (N) = Universal_Fixed
(Is_Real_Type (Etype (Rop))
and then Expr_Value_R (Rop) = Ureal_0))
then
- -- Specialize the warning message according to the operation
+ -- Specialize the warning message according to the operation.
+ -- The following warnings are for the case
case Nkind (N) is
when N_Op_Divide =>
- Apply_Compile_Time_Constraint_Error
- (N, "division by zero?", CE_Divide_By_Zero,
- Loc => Sloc (Right_Opnd (N)));
+
+ -- For division, we have two cases, for float division
+ -- of an unconstrained float type, on a machine where
+ -- Machine_Overflows is false, we don't get an exception
+ -- at run-time, but rather an infinity or Nan. The Nan
+ -- case is pretty obscure, so just warn about infinities.
+
+ if Is_Floating_Point_Type (Typ)
+ and then not Is_Constrained (Typ)
+ and then not Machine_Overflows_On_Target
+ then
+ Error_Msg_N
+ ("float division by zero, " &
+ "may generate '+'/'- infinity?", Right_Opnd (N));
+
+ -- For all other cases, we get a Constraint_Error
+
+ else
+ Apply_Compile_Time_Constraint_Error
+ (N, "division by zero?", CE_Divide_By_Zero,
+ Loc => Sloc (Right_Opnd (N)));
+ end if;
when N_Op_Rem =>
Apply_Compile_Time_Constraint_Error
-- decrease false positives, without losing too many good
-- warnings. The idea is that these previous statements
-- may affect global variables the procedure depends on.
+ -- We also exclude raise statements, that may arise from
+ -- constraint checks and are probably unrelated to the
+ -- intended control flow.
if Nkind (N) = N_Procedure_Call_Statement
and then Is_List_Member (N)
begin
P := Prev (N);
while Present (P) loop
- if Nkind (P) /= N_Assignment_Statement then
+ if not Nkind_In (P,
+ N_Assignment_Statement,
+ N_Raise_Constraint_Error)
+ then
exit Scope_Loop;
end if;
then
null;
- elsif Expander_Active
+ elsif Full_Expander_Active
and then Is_Type (Etype (Nam))
and then Requires_Transient_Scope (Etype (Nam))
and then
-- types or array types except String.
if Is_Boolean_Type (T) then
- Mark_Non_ALFA_Subprogram
- ("ordering operator on boolean type is not in 'A'L'F'A", N);
Check_SPARK_Restriction
("comparison is not defined on Boolean type", N);
- elsif Is_Array_Type (T) then
- Mark_Non_ALFA_Subprogram
- ("ordering operator on array type is not in 'A'L'F'A", N);
-
- if Base_Type (T) /= Standard_String then
- Check_SPARK_Restriction
- ("comparison is not defined on array types other than String",
- N);
- end if;
-
- else
- null;
+ elsif Is_Array_Type (T)
+ and then Base_Type (T) /= Standard_String
+ then
+ Check_SPARK_Restriction
+ ("comparison is not defined on array types other than String", N);
end if;
-- Check comparison on unordered enumeration
Append_To (Expressions (N), Error);
end if;
- if Root_Type (Typ) /= Standard_Boolean then
- Mark_Non_ALFA_Subprogram
- ("non-boolean conditional expression is not in 'A'L'F'A", N);
- end if;
-
Set_Etype (N, Typ);
Eval_Conditional_Expression (N);
end Resolve_Conditional_Expression;
-- Protected functions can return on the secondary stack, in which
-- case we must trigger the transient scope mechanism.
- elsif Expander_Active
+ elsif Full_Expander_Active
and then Requires_Transient_Scope (Etype (Nam))
then
Establish_Transient_Scope (N, Sec_Stack => True);
-- operands have equal static bounds.
if Is_Array_Type (T) then
- Mark_Non_ALFA_Subprogram
- ("equality operator on array is not in 'A'L'F'A", N);
-
-- Protect call to Matching_Static_Array_Bounds to avoid costly
-- operation if not needed.
-- Why the Expander_Active test here ???
- if Expander_Active
+ if Full_Expander_Active
and then
(Ekind_In (T, E_Anonymous_Access_Type,
E_Anonymous_Access_Subprogram_Type)
Arg1 : Node_Id;
Arg2 : Node_Id;
+ function Convert_Operand (Opnd : Node_Id) return Node_Id;
+ -- If the operand is a literal, it cannot be the expression in a
+ -- conversion. Use a qualified expression instead.
+
+ function Convert_Operand (Opnd : Node_Id) return Node_Id is
+ Loc : constant Source_Ptr := Sloc (Opnd);
+ Res : Node_Id;
+ begin
+ if Nkind_In (Opnd, N_Integer_Literal, N_Real_Literal) then
+ Res :=
+ Make_Qualified_Expression (Loc,
+ Subtype_Mark => New_Occurrence_Of (Btyp, Loc),
+ Expression => Relocate_Node (Opnd));
+ Analyze (Res);
+
+ else
+ Res := Unchecked_Convert_To (Btyp, Opnd);
+ end if;
+
+ return Res;
+ end Convert_Operand;
+
+ -- Start of processing for Resolve_Intrinsic_Operator
+
begin
-- We must preserve the original entity in a generic setting, so that
-- the legality of the operation can be verified in an instance.
- if not Expander_Active then
+ if not Full_Expander_Active then
return;
end if;
Set_Entity (N, Op);
Set_Is_Overloaded (N, False);
- -- If the operand type is private, rewrite with suitable conversions on
- -- the operands and the result, to expose the proper underlying numeric
- -- type.
+ -- If the result or operand types are private, rewrite with unchecked
+ -- conversions on the operands and the result, to expose the proper
+ -- underlying numeric type.
- if Is_Private_Type (Typ) then
- Arg1 := Unchecked_Convert_To (Btyp, Left_Opnd (N));
+ if Is_Private_Type (Typ)
+ or else Is_Private_Type (Etype (Left_Opnd (N)))
+ or else Is_Private_Type (Etype (Right_Opnd (N)))
+ then
+ Arg1 := Convert_Operand (Left_Opnd (N));
+ -- Unchecked_Convert_To (Btyp, Left_Opnd (N));
+ -- What on earth is this commented out fragment of code???
if Nkind (N) = N_Op_Expon then
Arg2 := Unchecked_Convert_To (Standard_Integer, Right_Opnd (N));
else
- Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N));
+ Arg2 := Convert_Operand (Right_Opnd (N));
end if;
if Nkind (Arg1) = N_Type_Conversion then
Check_For_Visible_Operator (N, B_Typ);
end if;
+ -- Replace AND by AND THEN, or OR by OR ELSE, if Short_Circuit_And_Or
+ -- is active and the result type is standard Boolean (do not mess with
+ -- ops that return a nonstandard Boolean type, because something strange
+ -- is going on).
+
+ -- Note: you might expect this replacement to be done during expansion,
+ -- but that doesn't work, because when the pragma Short_Circuit_And_Or
+ -- is used, no part of the right operand of an "and" or "or" operator
+ -- should be executed if the left operand would short-circuit the
+ -- evaluation of the corresponding "and then" or "or else". If we left
+ -- the replacement to expansion time, then run-time checks associated
+ -- with such operands would be evaluated unconditionally, due to being
+ -- before the condition prior to the rewriting as short-circuit forms
+ -- during expansion.
+
+ if Short_Circuit_And_Or
+ and then B_Typ = Standard_Boolean
+ and then Nkind_In (N, N_Op_And, N_Op_Or)
+ then
+ if Nkind (N) = N_Op_And then
+ Rewrite (N,
+ Make_And_Then (Sloc (N),
+ Left_Opnd => Relocate_Node (Left_Opnd (N)),
+ Right_Opnd => Relocate_Node (Right_Opnd (N))));
+ Analyze_And_Resolve (N, B_Typ);
+
+ -- Case of OR changed to OR ELSE
+
+ else
+ Rewrite (N,
+ Make_Or_Else (Sloc (N),
+ Left_Opnd => Relocate_Node (Left_Opnd (N)),
+ Right_Opnd => Relocate_Node (Right_Opnd (N))));
+ Analyze_And_Resolve (N, B_Typ);
+ end if;
+
+ -- Return now, since analysis of the rewritten ops will take care of
+ -- other reference bookkeeping and expression folding.
+
+ return;
+ end if;
+
Resolve (Left_Opnd (N), B_Typ);
Resolve (Right_Opnd (N), B_Typ);
if Is_Array_Type (B_Typ)
and then Nkind (N) in N_Binary_Op
then
- Mark_Non_ALFA_Subprogram
- ("binary operator on array is not in 'A'L'F'A", N);
-
declare
Left_Typ : constant Node_Id := Etype (Left_Opnd (N));
Right_Typ : constant Node_Id := Etype (Right_Opnd (N));
+
begin
-- Protect call to Matching_Static_Array_Bounds to avoid costly
-- operation if not needed.
if Is_Character_Type (Etype (Arg)) then
if not Is_Static_Expression (Arg) then
Check_SPARK_Restriction
- ("character operand for concatenation should be static", N);
+ ("character operand for concatenation should be static", Arg);
end if;
elsif Is_String_Type (Etype (Arg)) then
and then not Is_Static_Expression (Arg)
then
Check_SPARK_Restriction
- ("string operand for concatenation should be static", N);
+ ("string operand for concatenation should be static", Arg);
end if;
-- Do not issue error on an operand that is neither a character nor a
if Is_Fixed_Point_Type (Typ) and then Comes_From_Source (N) then
Error_Msg_N ("exponentiation not available for fixed point", N);
return;
+
+ elsif Nkind (Parent (N)) in N_Op
+ and then Is_Fixed_Point_Type (Etype (Parent (N)))
+ and then Etype (N) = Universal_Real
+ and then Comes_From_Source (N)
+ then
+ Error_Msg_N ("exponentiation not available for fixed point", N);
+ return;
end if;
if Comes_From_Source (N)
procedure Resolve_Quantified_Expression (N : Node_Id; Typ : Entity_Id) is
begin
- -- The loop structure is already resolved during its analysis, only the
- -- resolution of the condition needs to be done. Expansion is disabled
- -- so that checks and other generated code are inserted in the tree
- -- after expression has been rewritten as a loop.
+ if not Alfa_Mode then
- Expander_Mode_Save_And_Set (False);
- Resolve (Condition (N), Typ);
- Expander_Mode_Restore;
+ -- If expansion is enabled, analysis is delayed until the expresssion
+ -- is rewritten as a loop.
+
+ if Operating_Mode /= Check_Semantics then
+ return;
+ end if;
+
+ -- The loop structure is already resolved during its analysis, only
+ -- the resolution of the condition needs to be done. Expansion is
+ -- disabled so that checks and other generated code are inserted in
+ -- the tree after expression has been rewritten as a loop.
+
+ Expander_Mode_Save_And_Set (False);
+ Resolve (Condition (N), Typ);
+ Expander_Mode_Restore;
+
+ -- In Alfa mode, we need normal expansion in order to properly introduce
+ -- the necessary transient scopes.
+
+ else
+ Resolve (Condition (N), Typ);
+ end if;
end Resolve_Quantified_Expression;
-------------------
-- transformation while analyzing generic units, as type information
-- would be lost when reanalyzing the constant node in the instance.
- if Is_Discrete_Type (Typ) and then Expander_Active then
+ if Is_Discrete_Type (Typ) and then Full_Expander_Active then
if Is_OK_Static_Expression (L) then
Fold_Uint (L, Expr_Value (L), Is_Static_Expression (L));
end if;
-- expression coincides with the target type.
if Ada_Version >= Ada_2005
- and then Expander_Active
+ and then Full_Expander_Active
and then Operand_Typ /= Target_Typ
then
declare
-- premature (e.g. if the slice is within a transient scope). This needs
-- to be done only if expansion is enabled.
- elsif Expander_Active then
+ elsif Full_Expander_Active then
Ensure_Defined (Typ => Slice_Subtype, N => N);
end if;
end Set_Slice_Subtype;
----------------------
function Valid_Conversion
- (N : Node_Id;
- Target : Entity_Id;
- Operand : Node_Id) return Boolean
+ (N : Node_Id;
+ Target : Entity_Id;
+ Operand : Node_Id;
+ Report_Errs : Boolean := True) return Boolean
is
Target_Type : constant Entity_Id := Base_Type (Target);
- Opnd_Type : Entity_Id := Etype (Operand);
+ Opnd_Type : Entity_Id := Etype (Operand);
function Conversion_Check
(Valid : Boolean;
Msg : String) return Boolean;
-- Little routine to post Msg if Valid is False, returns Valid value
+ -- The following are badly named, this kind of overloading is actively
+ -- confusing in reading code, please rename to something like
+ -- Error_Msg_N_If_Reporting ???
+
+ procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id);
+ -- If Report_Errs, then calls Errout.Error_Msg_N with its arguments
+
+ procedure Error_Msg_NE
+ (Msg : String;
+ N : Node_Or_Entity_Id;
+ E : Node_Or_Entity_Id);
+ -- If Report_Errs, then calls Errout.Error_Msg_NE with its arguments
+
function Valid_Tagged_Conversion
(Target_Type : Entity_Id;
Opnd_Type : Entity_Id) return Boolean;
Msg : String) return Boolean
is
begin
- if not Valid then
+ if not Valid
+
+ -- A generic unit has already been analyzed and we have verified
+ -- that a particular conversion is OK in that context. Since the
+ -- instance is reanalyzed without relying on the relationships
+ -- established during the analysis of the generic, it is possible
+ -- to end up with inconsistent views of private types. Do not emit
+ -- the error message in such cases. The rest of the machinery in
+ -- Valid_Conversion still ensures the proper compatibility of
+ -- target and operand types.
+
+ and then not In_Instance
+ then
Error_Msg_N (Msg, Operand);
end if;
return Valid;
end Conversion_Check;
+ -----------------
+ -- Error_Msg_N --
+ -----------------
+
+ procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id) is
+ begin
+ if Report_Errs then
+ Errout.Error_Msg_N (Msg, N);
+ end if;
+ end Error_Msg_N;
+
+ ------------------
+ -- Error_Msg_NE --
+ ------------------
+
+ procedure Error_Msg_NE
+ (Msg : String;
+ N : Node_Or_Entity_Id;
+ E : Node_Or_Entity_Id)
+ is
+ begin
+ if Report_Errs then
+ Errout.Error_Msg_NE (Msg, N, E);
+ end if;
+ end Error_Msg_NE;
+
----------------------------
-- Valid_Array_Conversion --
----------------------------
if Ekind (Target_Type) /= E_Anonymous_Access_Type then
if Type_Access_Level (Opnd_Type) >
- Type_Access_Level (Target_Type)
+ Deepest_Type_Access_Level (Target_Type)
then
-- In an instance, this is a run-time check, but one we know
-- will fail, so generate an appropriate warning. The raise
Operand);
Error_Msg_N
("\?Program_Error will be raised at run time", Operand);
+
else
Error_Msg_N
("cannot convert local pointer to non-local access type",
if Nkind (Operand) = N_Selected_Component
and then Object_Access_Level (Operand) >
- Type_Access_Level (Target_Type)
+ Deepest_Type_Access_Level (Target_Type)
then
-- In an instance, this is a run-time check, but one we know
-- will fail, so generate an appropriate warning. The raise
if Ekind (Target_Type) /= E_Anonymous_Access_Type
or else Is_Local_Anonymous_Access (Target_Type)
+ or else Nkind (Associated_Node_For_Itype (Target_Type)) =
+ N_Object_Declaration
then
- if Type_Access_Level (Opnd_Type)
- > Type_Access_Level (Target_Type)
+ -- Ada 2012 (AI05-0149): Perform legality checking on implicit
+ -- conversions from an anonymous access type to a named general
+ -- access type. Such conversions are not allowed in the case of
+ -- access parameters and stand-alone objects of an anonymous
+ -- access type. The implicit conversion case is recognized by
+ -- testing that Comes_From_Source is False and that it's been
+ -- rewritten. The Comes_From_Source test isn't sufficient because
+ -- nodes in inlined calls to predefined library routines can have
+ -- Comes_From_Source set to False. (Is there a better way to test
+ -- for implicit conversions???)
+
+ if Ada_Version >= Ada_2012
+ and then not Comes_From_Source (N)
+ and then N /= Original_Node (N)
+ and then Ekind (Target_Type) = E_General_Access_Type
+ and then Ekind (Opnd_Type) = E_Anonymous_Access_Type
+ then
+ if Is_Itype (Opnd_Type) then
+
+ -- Implicit conversions aren't allowed for objects of an
+ -- anonymous access type, since such objects have nonstatic
+ -- levels in Ada 2012.
+
+ if Nkind (Associated_Node_For_Itype (Opnd_Type)) =
+ N_Object_Declaration
+ then
+ Error_Msg_N
+ ("implicit conversion of stand-alone anonymous " &
+ "access object not allowed", Operand);
+ return False;
+
+ -- Implicit conversions aren't allowed for anonymous access
+ -- parameters. The "not Is_Local_Anonymous_Access_Type" test
+ -- is done to exclude anonymous access results.
+
+ elsif not Is_Local_Anonymous_Access (Opnd_Type)
+ and then Nkind_In (Associated_Node_For_Itype (Opnd_Type),
+ N_Function_Specification,
+ N_Procedure_Specification)
+ then
+ Error_Msg_N
+ ("implicit conversion of anonymous access formal " &
+ "not allowed", Operand);
+ return False;
+
+ -- This is a case where there's an enclosing object whose
+ -- to which the "statically deeper than" relationship does
+ -- not apply (such as an access discriminant selected from
+ -- a dereference of an access parameter).
+
+ elsif Object_Access_Level (Operand)
+ = Scope_Depth (Standard_Standard)
+ then
+ Error_Msg_N
+ ("implicit conversion of anonymous access value " &
+ "not allowed", Operand);
+ return False;
+
+ -- In other cases, the level of the operand's type must be
+ -- statically less deep than that of the target type, else
+ -- implicit conversion is disallowed (by RM12-8.6(27.1/3)).
+
+ elsif Type_Access_Level (Opnd_Type) >
+ Deepest_Type_Access_Level (Target_Type)
+ then
+ Error_Msg_N
+ ("implicit conversion of anonymous access value " &
+ "violates accessibility", Operand);
+ return False;
+ end if;
+ end if;
+
+ elsif Type_Access_Level (Opnd_Type) >
+ Deepest_Type_Access_Level (Target_Type)
then
-- In an instance, this is a run-time check, but one we know
-- will fail, so generate an appropriate warning. The raise
if Nkind (Operand) = N_Selected_Component
and then Object_Access_Level (Operand) >
- Type_Access_Level (Target_Type)
+ Deepest_Type_Access_Level (Target_Type)
then
-- In an instance, this is a run-time check, but one we know
-- will fail, so generate an appropriate warning. The raise
-- Check the static accessibility rule of 4.6(20)
if Type_Access_Level (Opnd_Type) >
- Type_Access_Level (Target_Type)
+ Deepest_Type_Access_Level (Target_Type)
then
Error_Msg_N
("operand type has deeper accessibility level than target",
OSDN Git Service
