with Debug; use Debug;
with Debug_A; use Debug_A;
with Einfo; use Einfo;
-with Elists; use Elists;
with Errout; use Errout;
with Expander; use Expander;
with Exp_Disp; use Exp_Disp;
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;
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;
("& 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 the allocator is an actual in a call, it is allowed to be class-
-- wide when the context is not because it is a controlling actual.
- procedure Propagate_Coextensions (Root : Node_Id);
- -- Propagate all nested coextensions which are located one nesting
- -- level down the tree to the node Root. Example:
- --
- -- Top_Record
- -- Level_1_Coextension
- -- Level_2_Coextension
- --
- -- The algorithm is paired with delay actions done by the Expander. In
- -- the above example, assume all coextensions are controlled types.
- -- The cycle of analysis, resolution and expansion will yield:
- --
- -- 1) Analyze Top_Record
- -- 2) Analyze Level_1_Coextension
- -- 3) Analyze Level_2_Coextension
- -- 4) Resolve Level_2_Coextension. The allocator is marked as a
- -- coextension.
- -- 5) Expand Level_2_Coextension. A temporary variable Temp_1 is
- -- generated to capture the allocated object. Temp_1 is attached
- -- to the coextension chain of Level_2_Coextension.
- -- 6) Resolve Level_1_Coextension. The allocator is marked as a
- -- coextension. A forward tree traversal is performed which finds
- -- Level_2_Coextension's list and copies its contents into its
- -- own list.
- -- 7) Expand Level_1_Coextension. A temporary variable Temp_2 is
- -- generated to capture the allocated object. Temp_2 is attached
- -- to the coextension chain of Level_1_Coextension. Currently, the
- -- contents of the list are [Temp_2, Temp_1].
- -- 8) Resolve Top_Record. A forward tree traversal is performed which
- -- finds Level_1_Coextension's list and copies its contents into
- -- its own list.
- -- 9) Expand Top_Record. Generate finalization calls for Temp_1 and
- -- Temp_2 and attach them to Top_Record's finalization list.
-
-------------------------------------------
-- Check_Allocator_Discrim_Accessibility --
-------------------------------------------
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",
function In_Dispatching_Context return Boolean is
Par : constant Node_Id := Parent (N);
- begin
- return Nkind_In (Par, N_Function_Call, N_Procedure_Call_Statement)
- and then Is_Entity_Name (Name (Par))
- and then Is_Dispatching_Operation (Entity (Name (Par)));
- end In_Dispatching_Context;
-
- ----------------------------
- -- Propagate_Coextensions --
- ----------------------------
-
- procedure Propagate_Coextensions (Root : Node_Id) is
-
- procedure Copy_List (From : Elist_Id; To : Elist_Id);
- -- Copy the contents of list From into list To, preserving the
- -- order of elements.
-
- function Process_Allocator (Nod : Node_Id) return Traverse_Result;
- -- Recognize an allocator or a rewritten allocator node and add it
- -- along with its nested coextensions to the list of Root.
-
- ---------------
- -- Copy_List --
- ---------------
-
- procedure Copy_List (From : Elist_Id; To : Elist_Id) is
- From_Elmt : Elmt_Id;
- begin
- From_Elmt := First_Elmt (From);
- while Present (From_Elmt) loop
- Append_Elmt (Node (From_Elmt), To);
- Next_Elmt (From_Elmt);
- end loop;
- end Copy_List;
-
- -----------------------
- -- Process_Allocator --
- -----------------------
-
- function Process_Allocator (Nod : Node_Id) return Traverse_Result is
- Orig_Nod : Node_Id := Nod;
-
- begin
- -- This is a possible rewritten subtype indication allocator. Any
- -- nested coextensions will appear as discriminant constraints.
-
- if Nkind (Nod) = N_Identifier
- and then Present (Original_Node (Nod))
- and then Nkind (Original_Node (Nod)) = N_Subtype_Indication
- then
- declare
- Discr : Node_Id;
- Discr_Elmt : Elmt_Id;
-
- begin
- if Is_Record_Type (Entity (Nod)) then
- Discr_Elmt :=
- First_Elmt (Discriminant_Constraint (Entity (Nod)));
- while Present (Discr_Elmt) loop
- Discr := Node (Discr_Elmt);
-
- if Nkind (Discr) = N_Identifier
- and then Present (Original_Node (Discr))
- and then Nkind (Original_Node (Discr)) = N_Allocator
- and then Present (Coextensions (
- Original_Node (Discr)))
- then
- if No (Coextensions (Root)) then
- Set_Coextensions (Root, New_Elmt_List);
- end if;
-
- Copy_List
- (From => Coextensions (Original_Node (Discr)),
- To => Coextensions (Root));
- end if;
-
- Next_Elmt (Discr_Elmt);
- end loop;
-
- -- There is no need to continue the traversal of this
- -- subtree since all the information has already been
- -- propagated.
-
- return Skip;
- end if;
- end;
-
- -- Case of either a stand alone allocator or a rewritten allocator
- -- with an aggregate.
-
- else
- if Present (Original_Node (Nod)) then
- Orig_Nod := Original_Node (Nod);
- end if;
-
- if Nkind (Orig_Nod) = N_Allocator then
-
- -- Propagate the list of nested coextensions to the Root
- -- allocator. This is done through list copy since a single
- -- allocator may have multiple coextensions. Do not touch
- -- coextensions roots.
-
- if not Is_Coextension_Root (Orig_Nod)
- and then Present (Coextensions (Orig_Nod))
- then
- if No (Coextensions (Root)) then
- Set_Coextensions (Root, New_Elmt_List);
- end if;
-
- Copy_List
- (From => Coextensions (Orig_Nod),
- To => Coextensions (Root));
- end if;
-
- -- There is no need to continue the traversal of this
- -- subtree since all the information has already been
- -- propagated.
-
- return Skip;
- end if;
- end if;
-
- -- Keep on traversing, looking for the next allocator
-
- return OK;
- end Process_Allocator;
-
- procedure Process_Allocators is
- new Traverse_Proc (Process_Allocator);
-
- -- Start of processing for Propagate_Coextensions
begin
- Process_Allocators (Expression (Root));
- end Propagate_Coextensions;
+ return
+ Nkind_In (Par, N_Function_Call,
+ N_Procedure_Call_Statement)
+ and then Is_Entity_Name (Name (Par))
+ and then Is_Dispatching_Operation (Entity (Name (Par)));
+ end In_Dispatching_Context;
-- Start of processing for Resolve_Allocator
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;
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);
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_Dynamic_Coextension (N, False);
Set_Is_Static_Coextension (N, False);
end if;
+ end if;
- -- There is no need to propagate any nested coextensions if they
- -- are marked as static since they will be rewritten on the spot.
+ -- 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 not Is_Static_Coextension (N) then
- Propagate_Coextensions (N);
- end if;
+ 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
-- and then Is_Inherited_Operation_For_Type
-- (Entity (Name (N)), Etype (N))
-- then
--- Check_Formal_Restriction ("function not inherited", N);
+-- Check_SPARK_Restriction ("function not inherited", N);
-- end if;
-- Implement rule in 12.5.1 (23.3/2): In an instance, if the actual is
-- types or array types except String.
if Is_Boolean_Type (T) then
- Mark_Non_ALFA_Subprogram;
Check_SPARK_Restriction
("comparison is not defined on Boolean type", N);
- elsif Is_Array_Type (T) then
- Mark_Non_ALFA_Subprogram;
-
- 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
-- 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;
-
-- 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;
-
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.
Is_Comp : Boolean)
is
Btyp : constant Entity_Id := Base_Type (Typ);
+ Ctyp : constant Entity_Id := Component_Type (Typ);
begin
if In_Instance then
if Is_Comp
or else (not Is_Overloaded (Arg)
and then Etype (Arg) /= Any_Composite
- and then Covers (Component_Type (Typ), Etype (Arg)))
+ and then Covers (Ctyp, Etype (Arg)))
then
- Resolve (Arg, Component_Type (Typ));
+ Resolve (Arg, Ctyp);
else
Resolve (Arg, Btyp);
end if;
- elsif Has_Compatible_Type (Arg, Component_Type (Typ)) then
+ -- If both Array & Array and Array & Component are visible, there is a
+ -- potential ambiguity that must be reported.
+
+ elsif Has_Compatible_Type (Arg, Ctyp) then
if Nkind (Arg) = N_Aggregate
- and then Is_Composite_Type (Component_Type (Typ))
+ and then Is_Composite_Type (Ctyp)
then
- if Is_Private_Type (Component_Type (Typ)) then
+ if Is_Private_Type (Ctyp) then
Resolve (Arg, Btyp);
+
+ -- If the operation is user-defined and not overloaded use its
+ -- profile. The operation may be a renaming, in which case it has
+ -- been rewritten, and we want the original profile.
+
+ elsif not Is_Overloaded (N)
+ and then Comes_From_Source (Entity (Original_Node (N)))
+ and then Ekind (Entity (Original_Node (N))) = E_Function
+ then
+ Resolve (Arg,
+ Etype
+ (Next_Formal (First_Formal (Entity (Original_Node (N))))));
+ return;
+
+ -- Otherwise an aggregate may match both the array type and the
+ -- component type.
+
else
Error_Msg_N ("ambiguous aggregate must be qualified", Arg);
Set_Etype (Arg, Any_Type);
Arg, Component_Type (Typ));
else
- Error_Msg_N
- ("ambiguous operand for concatenation!", Arg);
+ Error_Msg_N ("ambiguous operand for concatenation!", Arg);
Get_First_Interp (Arg, I, It);
while Present (It.Nam) loop
Error_Msg_Sloc := Sloc (It.Nam);
- if Base_Type (It.Typ) = Base_Type (Typ)
- or else Base_Type (It.Typ) =
- Base_Type (Component_Type (Typ))
+ if Base_Type (It.Typ) = Btyp
+ or else
+ Base_Type (It.Typ) = Base_Type (Ctyp)
then
Error_Msg_N -- CODEFIX
("\\possible interpretation#", Arg);
end if;
-- Concatenation is restricted in SPARK: each operand must be either a
- -- string literal, a static character expression, or another
- -- concatenation. Arg cannot be a concatenation here as callers of
- -- Resolve_Op_Concat_Arg call it separately on each final operand, past
- -- concatenation operations.
+ -- string literal, the name of a string constant, a static character or
+ -- string expression, or another concatenation. Arg cannot be a
+ -- concatenation here as callers of Resolve_Op_Concat_Arg call it
+ -- separately on each final operand, past concatenation operations.
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
- if not Is_Static_Expression (Arg) then
+ if not (Nkind_In (Arg, N_Identifier, N_Expanded_Name)
+ and then Is_Constant_Object (Entity (Arg)))
+ 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;
T := It.Typ;
end if;
- if Is_Record_Type (T) then
+ -- Locate selected component. For a private prefix the selector
+ -- can denote a discriminant.
+
+ if Is_Record_Type (T) or else Is_Private_Type (T) then
-- The visible components of a class-wide type are those of
-- the root type.
-- 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;
Index : Node_Id;
begin
- Set_String_Literal_Low_Bound
- (Subtype_Id,
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_First,
- Prefix =>
- New_Occurrence_Of (Base_Type (Index_Type), Loc)));
- Set_Etype (String_Literal_Low_Bound (Subtype_Id), Index_Type);
+ if Is_Integer_Type (Index_Type) then
+ Set_String_Literal_Low_Bound
+ (Subtype_Id, Make_Integer_Literal (Loc, 1));
+
+ else
+ -- If the index type is an enumeration type, build bounds
+ -- expression with attributes.
+
+ Set_String_Literal_Low_Bound
+ (Subtype_Id,
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_First,
+ Prefix =>
+ New_Occurrence_Of (Base_Type (Index_Type), Loc)));
+ Set_Etype (String_Literal_Low_Bound (Subtype_Id), Index_Type);
+ end if;
+
Analyze_And_Resolve (String_Literal_Low_Bound (Subtype_Id));
-- Build bona fide subtype for the string, and wrap it in an
----------------------
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
