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
-- Start of processing for Replace_Actual_Discriminants
begin
- if not Expander_Active then
+ if not Full_Expander_Active then
return;
end if;
It1 : Interp;
Seen : Entity_Id := Empty; -- prevent junk warning
- procedure Build_Explicit_Dereference
- (Expr : Node_Id;
- Disc : Entity_Id);
- -- AI05-139: Names with implicit dereference. If the expression N is a
- -- reference type and the context imposes the corresponding designated
- -- type, convert N into N.Disc.all. Such expressions are always over-
- -- loaded with both interpretations, and the dereference interpretation
- -- carries the name of the reference discriminant.
-
function Comes_From_Predefined_Lib_Unit (Nod : Node_Id) return Boolean;
-- Determine whether a node comes from a predefined library unit or
-- Standard.
procedure Resolution_Failed;
-- Called when attempt at resolving current expression fails
- --------------------------------
- -- Build_Explicit_Dereference --
- --------------------------------
-
- procedure Build_Explicit_Dereference
- (Expr : Node_Id;
- Disc : Entity_Id)
- is
- Loc : constant Source_Ptr := Sloc (Expr);
-
- begin
- Set_Is_Overloaded (Expr, False);
- Rewrite (Expr,
- Make_Explicit_Dereference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix => Relocate_Node (Expr),
- Selector_Name => New_Occurrence_Of (Disc, Loc))));
-
- Set_Etype (Prefix (Expr), Etype (Disc));
- Set_Etype (Expr, Typ);
- end Build_Explicit_Dereference;
-
------------------------------------
-- Comes_From_Predefined_Lib_Unit --
-------------------------------------
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
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;
if Is_Atomic_Object (A)
and then not Is_Atomic (Etype (F))
then
- Error_Msg_N
- ("cannot pass atomic argument to non-atomic formal",
- N);
+ Error_Msg_NE
+ ("cannot pass atomic argument to non-atomic formal&",
+ A, F);
elsif Is_Volatile_Object (A)
and then not Is_Volatile (Etype (F))
then
- Error_Msg_N
- ("cannot pass volatile argument to non-volatile formal",
- N);
+ Error_Msg_NE
+ ("cannot pass volatile argument to non-volatile formal&",
+ A, F);
end if;
end if;
-- If it is a named association, treat the selector_name as a
-- proper identifier, and mark the corresponding entity. Ignore
- -- this reference in ALFA mode, as it refers to an entity not in
+ -- 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
- and then not ALFA_Mode
+ and then not Alfa_Mode
then
Set_Entity (Selector_Name (Parent (A)), F);
Generate_Reference (F, Selector_Name (Parent (A)));
is
begin
if Type_Access_Level (Etype (Disc_Exp)) >
- Type_Access_Level (Alloc_Typ)
+ Deepest_Type_Access_Level (Alloc_Typ)
then
Error_Msg_N
("operand type has deeper level than allocator type", Disc_Exp);
-- object must not be deeper than that of the allocator's type.
elsif Nkind (Disc_Exp) = N_Attribute_Reference
- and then Get_Attribute_Id (Attribute_Name (Disc_Exp))
- = Attribute_Access
- and then Object_Access_Level (Prefix (Disc_Exp))
- > Type_Access_Level (Alloc_Typ)
+ and then Get_Attribute_Id (Attribute_Name (Disc_Exp)) =
+ Attribute_Access
+ and then Object_Access_Level (Prefix (Disc_Exp)) >
+ Deepest_Type_Access_Level (Alloc_Typ)
then
Error_Msg_N
("prefix of attribute has deeper level than allocator type",
elsif Ekind (Etype (Disc_Exp)) = E_Anonymous_Access_Type
and then Nkind (Disc_Exp) = N_Selected_Component
- and then Object_Access_Level (Prefix (Disc_Exp))
- > Type_Access_Level (Alloc_Typ)
+ and then Object_Access_Level (Prefix (Disc_Exp)) >
+ Deepest_Type_Access_Level (Alloc_Typ)
then
Error_Msg_N
("access discriminant has deeper level than allocator type",
Exp_Typ := Entity (E);
end if;
- if Type_Access_Level (Exp_Typ) > Type_Access_Level (Typ) then
+ if Type_Access_Level (Exp_Typ) >
+ Deepest_Type_Access_Level (Typ)
+ then
if In_Instance_Body then
Error_Msg_N ("?type in allocator has deeper level than" &
" designated class-wide type", E);
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.
+ -- 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 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 ("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
then
null;
- elsif Expander_Active
+ elsif Full_Expander_Active
and then Is_Type (Etype (Nam))
and then Requires_Transient_Scope (Etype (Nam))
and then
-- 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);
-- 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)
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
+ 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));
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_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
procedure Resolve_Quantified_Expression (N : Node_Id; Typ : Entity_Id) is
begin
- if not ALFA_Mode then
+ if not Alfa_Mode then
+
+ -- 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
Expander_Mode_Save_And_Set (False);
Resolve (Condition (N), Typ);
Expander_Mode_Restore;
- else
- -- In ALFA_Mode, no such magic needs to happen, we just resolve the
- -- underlying nodes.
+ -- 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 --
----------------------------
Subtypes_Statically_Match (Target_Comp_Type, Opnd_Comp_Type)
then
if Type_Access_Level (Target_Type) <
- Type_Access_Level (Opnd_Type)
+ Deepest_Type_Access_Level (Opnd_Type)
then
if In_Instance_Body then
- Error_Msg_N ("?source array type " &
- "has deeper accessibility level than target", Operand);
- Error_Msg_N ("\?Program_Error will be raised at run time",
- Operand);
+ Error_Msg_N
+ ("?source array type has " &
+ "deeper accessibility level than target", Operand);
+ Error_Msg_N
+ ("\?Program_Error will be raised at run time",
+ Operand);
Rewrite (N,
Make_Raise_Program_Error (Sloc (N),
Reason => PE_Accessibility_Check_Failed));
-- Conversion not allowed because of accessibility levels
else
- Error_Msg_N ("source array type " &
- "has deeper accessibility level than target", Operand);
+ Error_Msg_N
+ ("source array type has " &
+ "deeper accessibility level than target", Operand);
return False;
end if;
-- All of this is checked in Subtypes_Statically_Match.
if not Subtypes_Statically_Match
- (Target_Comp_Type, Opnd_Comp_Type)
+ (Target_Comp_Type, Opnd_Comp_Type)
then
Error_Msg_N
("component subtypes must statically match", Operand);
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",
N);
return True;
+ -- If it was legal in the generic, it's legal in the instance
+
+ elsif In_Instance_Body then
+ return True;
+
-- If both are tagged types, check legality of view conversions
elsif Is_Tagged_Type (Target_Type)
OSDN Git Service
