Google Git
Sign in
gnu / gcc / 926d9947847a0683cf34de6fc231209747576088 / . / gcc / ada / sem_res.adb
blob: 69cd3396de764767e0e1fe8b71041d0f70acee90 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S E M _ R E S --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
with Debug_A; use Debug_A;
with Einfo; use Einfo;
with Errout; use Errout;
with Expander; use Expander;
with Exp_Disp; use Exp_Disp;
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Fname; use Fname;
with Freeze; use Freeze;
with Ghost; use Ghost;
with Inline; use Inline;
with Itypes; use Itypes;
with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
with Namet; use Namet;
with Nmake; use Nmake;
with Nlists; use Nlists;
with Opt; use Opt;
with Output; use Output;
with Par_SCO; use Par_SCO;
with Restrict; use Restrict;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Aggr; use Sem_Aggr;
with Sem_Attr; use Sem_Attr;
with Sem_Cat; use Sem_Cat;
with Sem_Ch4; use Sem_Ch4;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
with Sem_Dim; use Sem_Dim;
with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist;
with Sem_Elim; use Sem_Elim;
with Sem_Elab; use Sem_Elab;
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;
with Sinfo.CN; use Sinfo.CN;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
with Style; use Style;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
with Urealp; use Urealp;
package body Sem_Res is
-----------------------
-- Local Subprograms --
-----------------------
-- Second pass (top-down) type checking and overload resolution procedures
-- Typ is the type required by context. These procedures propagate the
-- type information recursively to the descendants of N. If the node is not
-- overloaded, its Etype is established in the first pass. If overloaded,
-- the Resolve routines set the correct type. For arithmetic operators, the
-- Etype is the base type of the context.
-- Note that Resolve_Attribute is separated off in Sem_Attr
procedure Check_Discriminant_Use (N : Node_Id);
-- Enforce the restrictions on the use of discriminants when constraining
-- a component of a discriminated type (record or concurrent type).
procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id);
-- Given a node for an operator associated with type T, check that the
-- operator is visible. Operators all of whose operands are universal must
-- be checked for visibility during resolution because their type is not
-- determinable based on their operands.
procedure Check_Fully_Declared_Prefix
(Typ : Entity_Id;
Pref : Node_Id);
-- Check that the type of the prefix of a dereference is not incomplete
function Check_Infinite_Recursion (N : Node_Id) return Boolean;
-- Given a call node, N, which is known to occur immediately within the
-- subprogram being called, determines whether it is a detectable case of
-- an infinite recursion, and if so, outputs appropriate messages. Returns
-- True if an infinite recursion is detected, and False otherwise.
procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id);
-- If the type of the object being initialized uses the secondary stack
-- directly or indirectly, create a transient scope for the call to the
-- init proc. This is because we do not create transient scopes for the
-- initialization of individual components within the init proc itself.
-- Could be optimized away perhaps?
procedure Check_No_Direct_Boolean_Operators (N : Node_Id);
-- N is the node for a logical operator. If the operator is predefined, and
-- the root type of the operands is Standard.Boolean, then a check is made
-- for restriction No_Direct_Boolean_Operators. This procedure also handles
-- the style check for Style_Check_Boolean_And_Or.
function Is_Atomic_Ref_With_Address (N : Node_Id) return Boolean;
-- N is either an indexed component or a selected component. This function
-- returns true if the prefix refers to an object that has an address
-- clause (the case in which we may want to issue a warning).
function Is_Definite_Access_Type (E : Entity_Id) return Boolean;
-- Determine whether E is an access type declared by an access declaration,
-- and not an (anonymous) allocator type.
function Is_Predefined_Op (Nam : Entity_Id) return Boolean;
-- Utility to check whether the entity for an operator is a predefined
-- operator, in which case the expression is left as an operator in the
-- tree (else it is rewritten into a call). An instance of an intrinsic
-- conversion operation may be given an operator name, but is not treated
-- like an operator. Note that an operator that is an imported back-end
-- builtin has convention Intrinsic, but is expected to be rewritten into
-- a call, so such an operator is not treated as predefined by this
-- predicate.
procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id);
-- If a default expression in entry call N depends on the discriminants
-- of the task, it must be replaced with a reference to the discriminant
-- of the task being called.
procedure Resolve_Op_Concat_Arg
(N : Node_Id;
Arg : Node_Id;
Typ : Entity_Id;
Is_Comp : Boolean);
-- Internal procedure for Resolve_Op_Concat to resolve one operand of
-- concatenation operator. The operand is either of the array type or of
-- the component type. If the operand is an aggregate, and the component
-- type is composite, this is ambiguous if component type has aggregates.
procedure Resolve_Op_Concat_First (N : Node_Id; Typ : Entity_Id);
-- Does the first part of the work of Resolve_Op_Concat
procedure Resolve_Op_Concat_Rest (N : Node_Id; Typ : Entity_Id);
-- Does the "rest" of the work of Resolve_Op_Concat, after the left operand
-- has been resolved. See Resolve_Op_Concat for details.
procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Call (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Case_Expression (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Expression_With_Actions (N : Node_Id; Typ : Entity_Id);
procedure Resolve_If_Expression (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Generalized_Indexing (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Indexed_Component (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Integer_Literal (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Null (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Operator_Symbol (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Op_Concat (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Raise_Expression (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Range (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Selected_Component (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Shift (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Short_Circuit (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Slice (N : Node_Id; Typ : Entity_Id);
procedure Resolve_String_Literal (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Unchecked_Expression (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Unchecked_Type_Conversion (N : Node_Id; Typ : Entity_Id);
function Operator_Kind
(Op_Name : Name_Id;
Is_Binary : Boolean) return Node_Kind;
-- Utility to map the name of an operator into the corresponding Node. Used
-- by other node rewriting procedures.
procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id);
-- Resolve actuals of call, and add default expressions for missing ones.
-- N is the Node_Id for the subprogram call, and Nam is the entity of the
-- called subprogram.
procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id);
-- Called from Resolve_Call, when the prefix denotes an entry or element
-- of entry family. Actuals are resolved as for subprograms, and the node
-- is rebuilt as an entry call. Also called for protected operations. Typ
-- is the context type, which is used when the operation is a protected
-- function with no arguments, and the return value is indexed.
procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id);
-- A call to a user-defined intrinsic operator is rewritten as a call to
-- the corresponding predefined operator, with suitable conversions. Note
-- that this applies only for intrinsic operators that denote predefined
-- operators, not ones that are intrinsic imports of back-end builtins.
procedure Resolve_Intrinsic_Unary_Operator (N : Node_Id; Typ : Entity_Id);
-- Ditto, for arithmetic unary operators
procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id);
-- If an operator node resolves to a call to a user-defined operator,
-- rewrite the node as a function call.
procedure Make_Call_Into_Operator
(N : Node_Id;
Typ : Entity_Id;
Op_Id : Entity_Id);
-- Inverse transformation: if an operator is given in functional notation,
-- then after resolving the node, transform into an operator node, so that
-- operands are resolved properly. Recall that predefined operators do not
-- have a full signature and special resolution rules apply.
procedure Rewrite_Renamed_Operator
(N : Node_Id;
Op : Entity_Id;
Typ : Entity_Id);
-- An operator can rename another, e.g. in an instantiation. In that
-- case, the proper operator node must be constructed and resolved.
procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id);
-- The String_Literal_Subtype is built for all strings that are not
-- operands of a static concatenation operation. If the argument is not
-- a N_String_Literal node, then the call has no effect.
procedure Set_Slice_Subtype (N : Node_Id);
-- Build subtype of array type, with the range specified by the slice
procedure Simplify_Type_Conversion (N : Node_Id);
-- Called after N has been resolved and evaluated, but before range checks
-- have been applied. Currently simplifies a combination of floating-point
-- to integer conversion and Rounding or Truncation attribute.
function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id;
-- A universal_fixed expression in an universal context is unambiguous if
-- there is only one applicable fixed point type. Determining whether there
-- is only one requires a search over all visible entities, and happens
-- only in very pathological cases (see 6115-006).
-------------------------
-- Ambiguous_Character --
-------------------------
procedure Ambiguous_Character (C : Node_Id) is
E : Entity_Id;
begin
if Nkind (C) = N_Character_Literal then
Error_Msg_N ("ambiguous character literal", C);
-- First the ones in Standard
Error_Msg_N ("\\possible interpretation: Character!", C);
Error_Msg_N ("\\possible interpretation: Wide_Character!", C);
-- Include Wide_Wide_Character in Ada 2005 mode
if Ada_Version >= Ada_2005 then
Error_Msg_N ("\\possible interpretation: Wide_Wide_Character!", C);
end if;
-- Now any other types that match
E := Current_Entity (C);
while Present (E) loop
Error_Msg_NE ("\\possible interpretation:}!", C, Etype (E));
E := Homonym (E);
end loop;
end if;
end Ambiguous_Character;
-------------------------
-- Analyze_And_Resolve --
-------------------------
procedure Analyze_And_Resolve (N : Node_Id) is
begin
Analyze (N);
Resolve (N);
end Analyze_And_Resolve;
procedure Analyze_And_Resolve (N : Node_Id; Typ : Entity_Id) is
begin
Analyze (N);
Resolve (N, Typ);
end Analyze_And_Resolve;
-- Versions with check(s) suppressed
procedure Analyze_And_Resolve
(N : Node_Id;
Typ : Entity_Id;
Suppress : Check_Id)
is
Scop : constant Entity_Id := Current_Scope;
begin
if Suppress = All_Checks then
declare
Sva : constant Suppress_Array := Scope_Suppress.Suppress;
begin
Scope_Suppress.Suppress := (others => True);
Analyze_And_Resolve (N, Typ);
Scope_Suppress.Suppress := Sva;
end;
else
declare
Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
begin
Scope_Suppress.Suppress (Suppress) := True;
Analyze_And_Resolve (N, Typ);
Scope_Suppress.Suppress (Suppress) := Svg;
end;
end if;
if Current_Scope /= Scop
and then Scope_Is_Transient
then
-- This can only happen if a transient scope was created for an inner
-- expression, which will be removed upon completion of the analysis
-- of an enclosing construct. The transient scope must have the
-- suppress status of the enclosing environment, not of this Analyze
-- call.
Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress :=
Scope_Suppress;
end if;
end Analyze_And_Resolve;
procedure Analyze_And_Resolve
(N : Node_Id;
Suppress : Check_Id)
is
Scop : constant Entity_Id := Current_Scope;
begin
if Suppress = All_Checks then
declare
Sva : constant Suppress_Array := Scope_Suppress.Suppress;
begin
Scope_Suppress.Suppress := (others => True);
Analyze_And_Resolve (N);
Scope_Suppress.Suppress := Sva;
end;
else
declare
Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
begin
Scope_Suppress.Suppress (Suppress) := True;
Analyze_And_Resolve (N);
Scope_Suppress.Suppress (Suppress) := Svg;
end;
end if;
if Current_Scope /= Scop and then Scope_Is_Transient then
Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress :=
Scope_Suppress;
end if;
end Analyze_And_Resolve;
----------------------------
-- Check_Discriminant_Use --
----------------------------
procedure Check_Discriminant_Use (N : Node_Id) is
PN : constant Node_Id := Parent (N);
Disc : constant Entity_Id := Entity (N);
P : Node_Id;
D : Node_Id;
begin
-- Any use in a spec-expression is legal
if In_Spec_Expression then
null;
elsif Nkind (PN) = N_Range then
-- Discriminant cannot be used to constrain a scalar type
P := Parent (PN);
if Nkind (P) = N_Range_Constraint
and then Nkind (Parent (P)) = N_Subtype_Indication
and then Nkind (Parent (Parent (P))) = N_Component_Definition
then
Error_Msg_N ("discriminant cannot constrain scalar type", N);
elsif Nkind (P) = N_Index_Or_Discriminant_Constraint then
-- The following check catches the unusual case where a
-- discriminant appears within an index constraint that is part
-- of a larger expression within a constraint on a component,
-- e.g. "C : Int range 1 .. F (new A(1 .. D))". For now we only
-- check case of record components, and note that a similar check
-- should also apply in the case of discriminant constraints
-- below. ???
-- Note that the check for N_Subtype_Declaration below is to
-- detect the valid use of discriminants in the constraints of a
-- subtype declaration when this subtype declaration appears
-- inside the scope of a record type (which is syntactically
-- illegal, but which may be created as part of derived type
-- processing for records). See Sem_Ch3.Build_Derived_Record_Type
-- for more info.
if Ekind (Current_Scope) = E_Record_Type
and then Scope (Disc) = Current_Scope
and then not
(Nkind (Parent (P)) = N_Subtype_Indication
and then
Nkind_In (Parent (Parent (P)), N_Component_Definition,
N_Subtype_Declaration)
and then Paren_Count (N) = 0)
then
Error_Msg_N
("discriminant must appear alone in component constraint", N);
return;
end if;
-- Detect a common error:
-- type R (D : Positive := 100) is record
-- Name : String (1 .. D);
-- end record;
-- The default value causes an object of type R to be allocated
-- with room for Positive'Last characters. The RM does not mandate
-- the allocation of the maximum size, but that is what GNAT does
-- so we should warn the programmer that there is a problem.
Check_Large : declare
SI : Node_Id;
T : Entity_Id;
TB : Node_Id;
CB : Entity_Id;
function Large_Storage_Type (T : Entity_Id) return Boolean;
-- Return True if type T has a large enough range that any
-- array whose index type covered the whole range of the type
-- would likely raise Storage_Error.
------------------------
-- Large_Storage_Type --
------------------------
function Large_Storage_Type (T : Entity_Id) return Boolean is
begin
-- The type is considered large if its bounds are known at
-- compile time and if it requires at least as many bits as
-- a Positive to store the possible values.
return Compile_Time_Known_Value (Type_Low_Bound (T))
and then Compile_Time_Known_Value (Type_High_Bound (T))
and then
Minimum_Size (T, Biased => True) >=
RM_Size (Standard_Positive);
end Large_Storage_Type;
-- Start of processing for Check_Large
begin
-- Check that the Disc has a large range
if not Large_Storage_Type (Etype (Disc)) then
goto No_Danger;
end if;
-- If the enclosing type is limited, we allocate only the
-- default value, not the maximum, and there is no need for
-- a warning.
if Is_Limited_Type (Scope (Disc)) then
goto No_Danger;
end if;
-- Check that it is the high bound
if N /= High_Bound (PN)
or else No (Discriminant_Default_Value (Disc))
then
goto No_Danger;
end if;
-- Check the array allows a large range at this bound. First
-- find the array
SI := Parent (P);
if Nkind (SI) /= N_Subtype_Indication then
goto No_Danger;
end if;
T := Entity (Subtype_Mark (SI));
if not Is_Array_Type (T) then
goto No_Danger;
end if;
-- Next, find the dimension
TB := First_Index (T);
CB := First (Constraints (P));
while True
and then Present (TB)
and then Present (CB)
and then CB /= PN
loop
Next_Index (TB);
Next (CB);
end loop;
if CB /= PN then
goto No_Danger;
end if;
-- Now, check the dimension has a large range
if not Large_Storage_Type (Etype (TB)) then
goto No_Danger;
end if;
-- Warn about the danger
Error_Msg_N
("??creation of & object may raise Storage_Error!",
Scope (Disc));
<<No_Danger>>
null;
end Check_Large;
end if;
-- Legal case is in index or discriminant constraint
elsif Nkind_In (PN, N_Index_Or_Discriminant_Constraint,
N_Discriminant_Association)
then
if Paren_Count (N) > 0 then
Error_Msg_N
("discriminant in constraint must appear alone", N);
elsif Nkind (N) = N_Expanded_Name
and then Comes_From_Source (N)
then
Error_Msg_N
("discriminant must appear alone as a direct name", N);
end if;
return;
-- Otherwise, context is an expression. It should not be within (i.e. a
-- subexpression of) a constraint for a component.
else
D := PN;
P := Parent (PN);
while not Nkind_In (P, N_Component_Declaration,
N_Subtype_Indication,
N_Entry_Declaration)
loop
D := P;
P := Parent (P);
exit when No (P);
end loop;
-- If the discriminant is used in an expression that is a bound of a
-- scalar type, an Itype is created and the bounds are attached to
-- its range, not to the original subtype indication. Such use is of
-- course a double fault.
if (Nkind (P) = N_Subtype_Indication
and then Nkind_In (Parent (P), N_Component_Definition,
N_Derived_Type_Definition)
and then D = Constraint (P))
-- The constraint itself may be given by a subtype indication,
-- rather than by a more common discrete range.
or else (Nkind (P) = N_Subtype_Indication
and then
Nkind (Parent (P)) = N_Index_Or_Discriminant_Constraint)
or else Nkind (P) = N_Entry_Declaration
or else Nkind (D) = N_Defining_Identifier
then
Error_Msg_N
("discriminant in constraint must appear alone", N);
end if;
end if;
end Check_Discriminant_Use;
--------------------------------
-- Check_For_Visible_Operator --
--------------------------------
procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id) is
begin
if Is_Invisible_Operator (N, T) then
Error_Msg_NE -- CODEFIX
("operator for} is not directly visible!", N, First_Subtype (T));
Error_Msg_N -- CODEFIX
("use clause would make operation legal!", N);
end if;
end Check_For_Visible_Operator;
----------------------------------
-- Check_Fully_Declared_Prefix --
----------------------------------
procedure Check_Fully_Declared_Prefix
(Typ : Entity_Id;
Pref : Node_Id)
is
begin
-- Check that the designated type of the prefix of a dereference is
-- not an incomplete type. This cannot be done unconditionally, because
-- dereferences of private types are legal in default expressions. This
-- case is taken care of in Check_Fully_Declared, called below. There
-- are also 2005 cases where it is legal for the prefix to be unfrozen.
-- This consideration also applies to similar checks for allocators,
-- qualified expressions, and type conversions.
-- An additional exception concerns other per-object expressions that
-- are not directly related to component declarations, in particular
-- representation pragmas for tasks. These will be per-object
-- expressions if they depend on discriminants or some global entity.
-- If the task has access discriminants, the designated type may be
-- incomplete at the point the expression is resolved. This resolution
-- takes place within the body of the initialization procedure, where
-- the discriminant is replaced by its discriminal.
if Is_Entity_Name (Pref)
and then Ekind (Entity (Pref)) = E_In_Parameter
then
null;
-- Ada 2005 (AI-326): Tagged incomplete types allowed. The wrong usages
-- are handled by Analyze_Access_Attribute, Analyze_Assignment,
-- Analyze_Object_Renaming, and Freeze_Entity.
elsif Ada_Version >= Ada_2005
and then Is_Entity_Name (Pref)
and then Is_Access_Type (Etype (Pref))
and then Ekind (Directly_Designated_Type (Etype (Pref))) =
E_Incomplete_Type
and then Is_Tagged_Type (Directly_Designated_Type (Etype (Pref)))
then
null;
else
Check_Fully_Declared (Typ, Parent (Pref));
end if;
end Check_Fully_Declared_Prefix;
------------------------------
-- Check_Infinite_Recursion --
------------------------------
function Check_Infinite_Recursion (N : Node_Id) return Boolean is
P : Node_Id;
C : Node_Id;
function Same_Argument_List return Boolean;
-- Check whether list of actuals is identical to list of formals of
-- called function (which is also the enclosing scope).
------------------------
-- Same_Argument_List --
------------------------
function Same_Argument_List return Boolean is
A : Node_Id;
F : Entity_Id;
Subp : Entity_Id;
begin
if not Is_Entity_Name (Name (N)) then
return False;
else
Subp := Entity (Name (N));
end if;
F := First_Formal (Subp);
A := First_Actual (N);
while Present (F) and then Present (A) loop
if not Is_Entity_Name (A) or else Entity (A) /= F then
return False;
end if;
Next_Actual (A);
Next_Formal (F);
end loop;
return True;
end Same_Argument_List;
-- Start of processing for Check_Infinite_Recursion
begin
-- Special case, if this is a procedure call and is a call to the
-- current procedure with the same argument list, then this is for
-- sure an infinite recursion and we insert a call to raise SE.
if Is_List_Member (N)
and then List_Length (List_Containing (N)) = 1
and then Same_Argument_List
then
declare
P : constant Node_Id := Parent (N);
begin
if Nkind (P) = N_Handled_Sequence_Of_Statements
and then Nkind (Parent (P)) = N_Subprogram_Body
and then Is_Empty_List (Declarations (Parent (P)))
then
Error_Msg_Warn := SPARK_Mode /= On;
Error_Msg_N ("!infinite recursion<<", N);
Error_Msg_N ("\!Storage_Error [<<", N);
Insert_Action (N,
Make_Raise_Storage_Error (Sloc (N),
Reason => SE_Infinite_Recursion));
return True;
end if;
end;
end if;
-- If not that special case, search up tree, quitting if we reach a
-- construct (e.g. a conditional) that tells us that this is not a
-- case for an infinite recursion warning.
C := N;
loop
P := Parent (C);
-- If no parent, then we were not inside a subprogram, this can for
-- example happen when processing certain pragmas in a spec. Just
-- return False in this case.
if No (P) then
return False;
end if;
-- Done if we get to subprogram body, this is definitely an infinite
-- recursion case if we did not find anything to stop us.
exit when Nkind (P) = N_Subprogram_Body;
-- If appearing in conditional, result is false
if Nkind_In (P, N_Or_Else,
N_And_Then,
N_Case_Expression,
N_Case_Statement,
N_If_Expression,
N_If_Statement)
then
return False;
elsif Nkind (P) = N_Handled_Sequence_Of_Statements
and then C /= First (Statements (P))
then
-- If the call is the expression of a return statement and the
-- actuals are identical to the formals, it's worth a warning.
-- However, we skip this if there is an immediately preceding
-- raise statement, since the call is never executed.
-- Furthermore, this corresponds to a common idiom:
-- function F (L : Thing) return Boolean is
-- begin
-- raise Program_Error;
-- return F (L);
-- end F;
-- for generating a stub function
if Nkind (Parent (N)) = N_Simple_Return_Statement
and then Same_Argument_List
then
exit when not Is_List_Member (Parent (N));
-- OK, return statement is in a statement list, look for raise
declare
Nod : Node_Id;
begin
-- Skip past N_Freeze_Entity nodes generated by expansion
Nod := Prev (Parent (N));
while Present (Nod)
and then Nkind (Nod) = N_Freeze_Entity
loop
Prev (Nod);
end loop;
-- If no raise statement, give warning. We look at the
-- original node, because in the case of "raise ... with
-- ...", the node has been transformed into a call.
exit when Nkind (Original_Node (Nod)) /= N_Raise_Statement
and then
(Nkind (Nod) not in N_Raise_xxx_Error
or else Present (Condition (Nod)));
end;
end if;
return False;
else
C := P;
end if;
end loop;
Error_Msg_Warn := SPARK_Mode /= On;
Error_Msg_N ("!possible infinite recursion<<", N);
Error_Msg_N ("\!??Storage_Error ]<<", N);
return True;
end Check_Infinite_Recursion;
-------------------------------
-- Check_Initialization_Call --
-------------------------------
procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id) is
Typ : constant Entity_Id := Etype (First_Formal (Nam));
function Uses_SS (T : Entity_Id) return Boolean;
-- Check whether the creation of an object of the type will involve
-- use of the secondary stack. If T is a record type, this is true
-- if the expression for some component uses the secondary stack, e.g.
-- through a call to a function that returns an unconstrained value.
-- False if T is controlled, because cleanups occur elsewhere.
-------------
-- Uses_SS --
-------------
function Uses_SS (T : Entity_Id) return Boolean is
Comp : Entity_Id;
Expr : Node_Id;
Full_Type : Entity_Id := Underlying_Type (T);
begin
-- Normally we want to use the underlying type, but if it's not set
-- then continue with T.
if not Present (Full_Type) then
Full_Type := T;
end if;
if Is_Controlled (Full_Type) then
return False;
elsif Is_Array_Type (Full_Type) then
return Uses_SS (Component_Type (Full_Type));
elsif Is_Record_Type (Full_Type) then
Comp := First_Component (Full_Type);
while Present (Comp) loop
if Ekind (Comp) = E_Component
and then Nkind (Parent (Comp)) = N_Component_Declaration
then
-- The expression for a dynamic component may be rewritten
-- as a dereference, so retrieve original node.
Expr := Original_Node (Expression (Parent (Comp)));
-- Return True if the expression is a call to a function
-- (including an attribute function such as Image, or a
-- user-defined operator) with a result that requires a
-- transient scope.
if (Nkind (Expr) = N_Function_Call
or else Nkind (Expr) in N_Op
or else (Nkind (Expr) = N_Attribute_Reference
and then Present (Expressions (Expr))))
and then Requires_Transient_Scope (Etype (Expr))
then
return True;
elsif Uses_SS (Etype (Comp)) then
return True;
end if;
end if;
Next_Component (Comp);
end loop;
return False;
else
return False;
end if;
end Uses_SS;
-- Start of processing for Check_Initialization_Call
begin
-- Establish a transient scope if the type needs it
if Uses_SS (Typ) then
Establish_Transient_Scope (First_Actual (N), Sec_Stack => True);
end if;
end Check_Initialization_Call;
---------------------------------------
-- Check_No_Direct_Boolean_Operators --
---------------------------------------
procedure Check_No_Direct_Boolean_Operators (N : Node_Id) is
begin
if Scope (Entity (N)) = Standard_Standard
and then Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean
then
-- Restriction only applies to original source code
if Comes_From_Source (N) then
Check_Restriction (No_Direct_Boolean_Operators, N);
end if;
end if;
-- Do style check (but skip if in instance, error is on template)
if Style_Check then
if not In_Instance then
Check_Boolean_Operator (N);
end if;
end if;
end Check_No_Direct_Boolean_Operators;
------------------------------
-- Check_Parameterless_Call --
------------------------------
procedure Check_Parameterless_Call (N : Node_Id) is
Nam : Node_Id;
function Prefix_Is_Access_Subp return Boolean;
-- If the prefix is of an access_to_subprogram type, the node must be
-- rewritten as a call. Ditto if the prefix is overloaded and all its
-- interpretations are access to subprograms.
---------------------------
-- Prefix_Is_Access_Subp --
---------------------------
function Prefix_Is_Access_Subp return Boolean is
I : Interp_Index;
It : Interp;
begin
-- If the context is an attribute reference that can apply to
-- functions, this is never a parameterless call (RM 4.1.4(6)).
if Nkind (Parent (N)) = N_Attribute_Reference
and then Nam_In (Attribute_Name (Parent (N)), Name_Address,
Name_Code_Address,
Name_Access)
then
return False;
end if;
if not Is_Overloaded (N) then
return
Ekind (Etype (N)) = E_Subprogram_Type
and then Base_Type (Etype (Etype (N))) /= Standard_Void_Type;
else
Get_First_Interp (N, I, It);
while Present (It.Typ) loop
if Ekind (It.Typ) /= E_Subprogram_Type
or else Base_Type (Etype (It.Typ)) = Standard_Void_Type
then
return False;
end if;
Get_Next_Interp (I, It);
end loop;
return True;
end if;
end Prefix_Is_Access_Subp;
-- Start of processing for Check_Parameterless_Call
begin
-- Defend against junk stuff if errors already detected
if Total_Errors_Detected /= 0 then
if Nkind (N) in N_Has_Etype and then Etype (N) = Any_Type then
return;
elsif Nkind (N) in N_Has_Chars
and then Chars (N) in Error_Name_Or_No_Name
then
return;
end if;
Require_Entity (N);
end if;
-- If the context expects a value, and the name is a procedure, this is
-- most likely a missing 'Access. Don't try to resolve the parameterless
-- call, error will be caught when the outer call is analyzed.
if Is_Entity_Name (N)
and then Ekind (Entity (N)) = E_Procedure
and then not Is_Overloaded (N)
and then
Nkind_In (Parent (N), N_Parameter_Association,
N_Function_Call,
N_Procedure_Call_Statement)
then
return;
end if;
-- Rewrite as call if overloadable entity that is (or could be, in the
-- overloaded case) a function call. If we know for sure that the entity
-- is an enumeration literal, we do not rewrite it.
-- If the entity is the name of an operator, it cannot be a call because
-- operators cannot have default parameters. In this case, this must be
-- a string whose contents coincide with an operator name. Set the kind
-- of the node appropriately.
if (Is_Entity_Name (N)
and then Nkind (N) /= N_Operator_Symbol
and then Is_Overloadable (Entity (N))
and then (Ekind (Entity (N)) /= E_Enumeration_Literal
or else Is_Overloaded (N)))
-- Rewrite as call if it is an explicit dereference of an expression of
-- a subprogram access type, and the subprogram type is not that of a
-- procedure or entry.
or else
(Nkind (N) = N_Explicit_Dereference and then Prefix_Is_Access_Subp)
-- Rewrite as call if it is a selected component which is a function,
-- this is the case of a call to a protected function (which may be
-- overloaded with other protected operations).
or else
(Nkind (N) = N_Selected_Component
and then (Ekind (Entity (Selector_Name (N))) = E_Function
or else
(Ekind_In (Entity (Selector_Name (N)), E_Entry,
E_Procedure)
and then Is_Overloaded (Selector_Name (N)))))
-- If one of the above three conditions is met, rewrite as call. Apply
-- the rewriting only once.
then
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;
-- The node is the name of the parameterless call. Preserve its
-- descendants, which may be complex expressions.
Nam := Relocate_Node (N);
-- If overloaded, overload set belongs to new copy
Save_Interps (N, Nam);
-- Change node to parameterless function call (note that the
-- Parameter_Associations associations field is left set to Empty,
-- its normal default value since there are no parameters)
Change_Node (N, N_Function_Call);
Set_Name (N, Nam);
Set_Sloc (N, Sloc (Nam));
Analyze_Call (N);
end if;
elsif Nkind (N) = N_Parameter_Association then
Check_Parameterless_Call (Explicit_Actual_Parameter (N));
elsif Nkind (N) = N_Operator_Symbol then
Change_Operator_Symbol_To_String_Literal (N);
Set_Is_Overloaded (N, False);
Set_Etype (N, Any_String);
end if;
end Check_Parameterless_Call;
--------------------------------
-- Is_Atomic_Ref_With_Address --
--------------------------------
function Is_Atomic_Ref_With_Address (N : Node_Id) return Boolean is
Pref : constant Node_Id := Prefix (N);
begin
if not Is_Entity_Name (Pref) then
return False;
else
declare
Pent : constant Entity_Id := Entity (Pref);
Ptyp : constant Entity_Id := Etype (Pent);
begin
return not Is_Access_Type (Ptyp)
and then (Is_Atomic (Ptyp) or else Is_Atomic (Pent))
and then Present (Address_Clause (Pent));
end;
end if;
end Is_Atomic_Ref_With_Address;
-----------------------------
-- Is_Definite_Access_Type --
-----------------------------
function Is_Definite_Access_Type (E : Entity_Id) return Boolean is
Btyp : constant Entity_Id := Base_Type (E);
begin
return Ekind (Btyp) = E_Access_Type
or else (Ekind (Btyp) = E_Access_Subprogram_Type
and then Comes_From_Source (Btyp));
end Is_Definite_Access_Type;
----------------------
-- Is_Predefined_Op --
----------------------
function Is_Predefined_Op (Nam : Entity_Id) return Boolean is
begin
-- Predefined operators are intrinsic subprograms
if not Is_Intrinsic_Subprogram (Nam) then
return False;
end if;
-- A call to a back-end builtin is never a predefined operator
if Is_Imported (Nam) and then Present (Interface_Name (Nam)) then
return False;
end if;
return not Is_Generic_Instance (Nam)
and then Chars (Nam) in Any_Operator_Name
and then (No (Alias (Nam)) or else Is_Predefined_Op (Alias (Nam)));
end Is_Predefined_Op;
-----------------------------
-- Make_Call_Into_Operator --
-----------------------------
procedure Make_Call_Into_Operator
(N : Node_Id;
Typ : Entity_Id;
Op_Id : Entity_Id)
is
Op_Name : constant Name_Id := Chars (Op_Id);
Act1 : Node_Id := First_Actual (N);
Act2 : Node_Id := Next_Actual (Act1);
Error : Boolean := False;
Func : constant Entity_Id := Entity (Name (N));
Is_Binary : constant Boolean := Present (Act2);
Op_Node : Node_Id;
Opnd_Type : Entity_Id;
Orig_Type : Entity_Id := Empty;
Pack : Entity_Id;
type Kind_Test is access function (E : Entity_Id) return Boolean;
function Operand_Type_In_Scope (S : Entity_Id) return Boolean;
-- If the operand is not universal, and the operator is given by an
-- expanded name, verify that the operand has an interpretation with a
-- type defined in the given scope of the operator.
function Type_In_P (Test : Kind_Test) return Entity_Id;
-- Find a type of the given class in package Pack that contains the
-- operator.
---------------------------
-- Operand_Type_In_Scope --
---------------------------
function Operand_Type_In_Scope (S : Entity_Id) return Boolean is
Nod : constant Node_Id := Right_Opnd (Op_Node);
I : Interp_Index;
It : Interp;
begin
if not Is_Overloaded (Nod) then
return Scope (Base_Type (Etype (Nod))) = S;
else
Get_First_Interp (Nod, I, It);
while Present (It.Typ) loop
if Scope (Base_Type (It.Typ)) = S then
return True;
end if;
Get_Next_Interp (I, It);
end loop;
return False;
end if;
end Operand_Type_In_Scope;
---------------
-- Type_In_P --
---------------
function Type_In_P (Test : Kind_Test) return Entity_Id is
E : Entity_Id;
function In_Decl return Boolean;
-- Verify that node is not part of the type declaration for the
-- candidate type, which would otherwise be invisible.
-------------
-- In_Decl --
-------------
function In_Decl return Boolean is
Decl_Node : constant Node_Id := Parent (E);
N2 : Node_Id;
begin
N2 := N;
if Etype (E) = Any_Type then
return True;
elsif No (Decl_Node) then
return False;
else
while Present (N2)
and then Nkind (N2) /= N_Compilation_Unit
loop
if N2 = Decl_Node then
return True;
else
N2 := Parent (N2);
end if;
end loop;
return False;
end if;
end In_Decl;
-- Start of processing for Type_In_P
begin
-- If the context type is declared in the prefix package, this is the
-- desired base type.
if Scope (Base_Type (Typ)) = Pack and then Test (Typ) then
return Base_Type (Typ);
else
E := First_Entity (Pack);
while Present (E) loop
if Test (E) and then not In_Decl then
return E;
end if;
Next_Entity (E);
end loop;
return Empty;
end if;
end Type_In_P;
-- Start of processing for Make_Call_Into_Operator
begin
Op_Node := New_Node (Operator_Kind (Op_Name, Is_Binary), Sloc (N));
-- Binary operator
if Is_Binary then
Set_Left_Opnd (Op_Node, Relocate_Node (Act1));
Set_Right_Opnd (Op_Node, Relocate_Node (Act2));
Save_Interps (Act1, Left_Opnd (Op_Node));
Save_Interps (Act2, Right_Opnd (Op_Node));
Act1 := Left_Opnd (Op_Node);
Act2 := Right_Opnd (Op_Node);
-- Unary operator
else
Set_Right_Opnd (Op_Node, Relocate_Node (Act1));
Save_Interps (Act1, Right_Opnd (Op_Node));
Act1 := Right_Opnd (Op_Node);
end if;
-- If the operator is denoted by an expanded name, and the prefix is
-- not Standard, but the operator is a predefined one whose scope is
-- Standard, then this is an implicit_operator, inserted as an
-- interpretation by the procedure of the same name. This procedure
-- overestimates the presence of implicit operators, because it does
-- not examine the type of the operands. Verify now that the operand
-- type appears in the given scope. If right operand is universal,
-- check the other operand. In the case of concatenation, either
-- argument can be the component type, so check the type of the result.
-- If both arguments are literals, look for a type of the right kind
-- defined in the given scope. This elaborate nonsense is brought to
-- you courtesy of b33302a. The type itself must be frozen, so we must
-- find the type of the proper class in the given scope.
-- A final wrinkle is the multiplication operator for fixed point types,
-- which is defined in Standard only, and not in the scope of the
-- fixed point type itself.
if Nkind (Name (N)) = N_Expanded_Name then
Pack := Entity (Prefix (Name (N)));
-- If this is a package renaming, get renamed entity, which will be
-- the scope of the operands if operaton is type-correct.
if Present (Renamed_Entity (Pack)) then
Pack := Renamed_Entity (Pack);
end if;
-- If the entity being called is defined in the given package, it is
-- a renaming of a predefined operator, and known to be legal.
if Scope (Entity (Name (N))) = Pack
and then Pack /= Standard_Standard
then
null;
-- Visibility does not need to be checked in an instance: if the
-- operator was not visible in the generic it has been diagnosed
-- already, else there is an implicit copy of it in the instance.
elsif In_Instance then
null;
elsif Nam_In (Op_Name, Name_Op_Multiply, Name_Op_Divide)
and then Is_Fixed_Point_Type (Etype (Left_Opnd (Op_Node)))
and then Is_Fixed_Point_Type (Etype (Right_Opnd (Op_Node)))
then
if Pack /= Standard_Standard then
Error := True;
end if;
-- Ada 2005 AI-420: Predefined equality on Universal_Access is
-- available.
elsif Ada_Version >= Ada_2005
and then Nam_In (Op_Name, Name_Op_Eq, Name_Op_Ne)
and then Ekind (Etype (Act1)) = E_Anonymous_Access_Type
then
null;
else
Opnd_Type := Base_Type (Etype (Right_Opnd (Op_Node)));
if Op_Name = Name_Op_Concat then
Opnd_Type := Base_Type (Typ);
elsif (Scope (Opnd_Type) = Standard_Standard
and then Is_Binary)
or else (Nkind (Right_Opnd (Op_Node)) = N_Attribute_Reference
and then Is_Binary
and then not Comes_From_Source (Opnd_Type))
then
Opnd_Type := Base_Type (Etype (Left_Opnd (Op_Node)));
end if;
if Scope (Opnd_Type) = Standard_Standard then
-- Verify that the scope contains a type that corresponds to
-- the given literal. Optimize the case where Pack is Standard.
if Pack /= Standard_Standard then
if Opnd_Type = Universal_Integer then
Orig_Type := Type_In_P (Is_Integer_Type'Access);
elsif Opnd_Type = Universal_Real then
Orig_Type := Type_In_P (Is_Real_Type'Access);
elsif Opnd_Type = Any_String then
Orig_Type := Type_In_P (Is_String_Type'Access);
elsif Opnd_Type = Any_Access then
Orig_Type := Type_In_P (Is_Definite_Access_Type'Access);
elsif Opnd_Type = Any_Composite then
Orig_Type := Type_In_P (Is_Composite_Type'Access);
if Present (Orig_Type) then
if Has_Private_Component (Orig_Type) then
Orig_Type := Empty;
else
Set_Etype (Act1, Orig_Type);
if Is_Binary then
Set_Etype (Act2, Orig_Type);
end if;
end if;
end if;
else
Orig_Type := Empty;
end if;
Error := No (Orig_Type);
end if;
elsif Ekind (Opnd_Type) = E_Allocator_Type
and then No (Type_In_P (Is_Definite_Access_Type'Access))
then
Error := True;
-- If the type is defined elsewhere, and the operator is not
-- defined in the given scope (by a renaming declaration, e.g.)
-- then this is an error as well. If an extension of System is
-- present, and the type may be defined there, Pack must be
-- System itself.
elsif Scope (Opnd_Type) /= Pack
and then Scope (Op_Id) /= Pack
and then (No (System_Aux_Id)
or else Scope (Opnd_Type) /= System_Aux_Id
or else Pack /= Scope (System_Aux_Id))
then
if not Is_Overloaded (Right_Opnd (Op_Node)) then
Error := True;
else
Error := not Operand_Type_In_Scope (Pack);
end if;
elsif Pack = Standard_Standard
and then not Operand_Type_In_Scope (Standard_Standard)
then
Error := True;
end if;
end if;
if Error then
Error_Msg_Node_2 := Pack;
Error_Msg_NE
("& not declared in&", N, Selector_Name (Name (N)));
Set_Etype (N, Any_Type);
return;
-- Detect a mismatch between the context type and the result type
-- in the named package, which is otherwise not detected if the
-- operands are universal. Check is only needed if source entity is
-- an operator, not a function that renames an operator.
elsif Nkind (Parent (N)) /= N_Type_Conversion
and then Ekind (Entity (Name (N))) = E_Operator
and then Is_Numeric_Type (Typ)
and then not Is_Universal_Numeric_Type (Typ)
and then Scope (Base_Type (Typ)) /= Pack
and then not In_Instance
then
if Is_Fixed_Point_Type (Typ)
and then Nam_In (Op_Name, Name_Op_Multiply, Name_Op_Divide)
then
-- Already checked above
null;
-- Operator may be defined in an extension of System
elsif Present (System_Aux_Id)
and then Scope (Opnd_Type) = System_Aux_Id
then
null;
else
-- Could we use Wrong_Type here??? (this would require setting
-- Etype (N) to the actual type found where Typ was expected).
Error_Msg_NE ("expect }", N, Typ);
end if;
end if;
end if;
Set_Chars (Op_Node, Op_Name);
if not Is_Private_Type (Etype (N)) then
Set_Etype (Op_Node, Base_Type (Etype (N)));
else
Set_Etype (Op_Node, Etype (N));
end if;
-- If this is a call to a function that renames a predefined equality,
-- the renaming declaration provides a type that must be used to
-- resolve the operands. This must be done now because resolution of
-- the equality node will not resolve any remaining ambiguity, and it
-- assumes that the first operand is not overloaded.
if Nam_In (Op_Name, Name_Op_Eq, Name_Op_Ne)
and then Ekind (Func) = E_Function
and then Is_Overloaded (Act1)
then
Resolve (Act1, Base_Type (Etype (First_Formal (Func))));
Resolve (Act2, Base_Type (Etype (First_Formal (Func))));
end if;
Set_Entity (Op_Node, Op_Id);
Generate_Reference (Op_Id, N, ' ');
-- Do rewrite setting Comes_From_Source on the result if the original
-- call came from source. Although it is not strictly the case that the
-- operator as such comes from the source, logically it corresponds
-- exactly to the function call in the source, so it should be marked
-- this way (e.g. to make sure that validity checks work fine).
declare
CS : constant Boolean := Comes_From_Source (N);
begin
Rewrite (N, Op_Node);
Set_Comes_From_Source (N, CS);
end;
-- If this is an arithmetic operator and the result type is private,
-- the operands and the result must be wrapped in conversion to
-- expose the underlying numeric type and expand the proper checks,
-- e.g. on division.
if Is_Private_Type (Typ) then
case Nkind (N) is
when N_Op_Add | N_Op_Subtract | N_Op_Multiply | N_Op_Divide |
N_Op_Expon | N_Op_Mod | N_Op_Rem =>
Resolve_Intrinsic_Operator (N, Typ);
when N_Op_Plus | N_Op_Minus | N_Op_Abs =>
Resolve_Intrinsic_Unary_Operator (N, Typ);
when others =>
Resolve (N, Typ);
end case;
else
Resolve (N, Typ);
end if;
-- If in ASIS_Mode, propagate operand types to original actuals of
-- function call, which would otherwise not be fully resolved. If
-- the call has already been constant-folded, nothing to do. We
-- relocate the operand nodes rather than copy them, to preserve
-- original_node pointers, given that the operands themselves may
-- have been rewritten. If the call was itself a rewriting of an
-- operator node, nothing to do.
if ASIS_Mode
and then Nkind (N) in N_Op
and then Nkind (Original_Node (N)) = N_Function_Call
then
declare
L : Node_Id;
R : constant Node_Id := Right_Opnd (N);
Old_First : constant Node_Id :=
First (Parameter_Associations (Original_Node (N)));
Old_Sec : Node_Id;
begin
if Is_Binary then
L := Left_Opnd (N);
Old_Sec := Next (Old_First);
-- If the original call has named associations, replace the
-- explicit actual parameter in the association with the proper
-- resolved operand.
if Nkind (Old_First) = N_Parameter_Association then
if Chars (Selector_Name (Old_First)) =
Chars (First_Entity (Op_Id))
then
Rewrite (Explicit_Actual_Parameter (Old_First),
Relocate_Node (L));
else
Rewrite (Explicit_Actual_Parameter (Old_First),
Relocate_Node (R));
end if;
else
Rewrite (Old_First, Relocate_Node (L));
end if;
if Nkind (Old_Sec) = N_Parameter_Association then
if Chars (Selector_Name (Old_Sec)) =
Chars (First_Entity (Op_Id))
then
Rewrite (Explicit_Actual_Parameter (Old_Sec),
Relocate_Node (L));
else
Rewrite (Explicit_Actual_Parameter (Old_Sec),
Relocate_Node (R));
end if;
else
Rewrite (Old_Sec, Relocate_Node (R));
end if;
else
if Nkind (Old_First) = N_Parameter_Association then
Rewrite (Explicit_Actual_Parameter (Old_First),
Relocate_Node (R));
else
Rewrite (Old_First, Relocate_Node (R));
end if;
end if;
end;
Set_Parent (Original_Node (N), Parent (N));
end if;
end Make_Call_Into_Operator;
-------------------
-- Operator_Kind --
-------------------
function Operator_Kind
(Op_Name : Name_Id;
Is_Binary : Boolean) return Node_Kind
is
Kind : Node_Kind;
begin
-- Use CASE statement or array???
if Is_Binary then
if Op_Name = Name_Op_And then
Kind := N_Op_And;
elsif Op_Name = Name_Op_Or then
Kind := N_Op_Or;
elsif Op_Name = Name_Op_Xor then
Kind := N_Op_Xor;
elsif Op_Name = Name_Op_Eq then
Kind := N_Op_Eq;
elsif Op_Name = Name_Op_Ne then
Kind := N_Op_Ne;
elsif Op_Name = Name_Op_Lt then
Kind := N_Op_Lt;
elsif Op_Name = Name_Op_Le then
Kind := N_Op_Le;
elsif Op_Name = Name_Op_Gt then
Kind := N_Op_Gt;
elsif Op_Name = Name_Op_Ge then
Kind := N_Op_Ge;
elsif Op_Name = Name_Op_Add then
Kind := N_Op_Add;
elsif Op_Name = Name_Op_Subtract then
Kind := N_Op_Subtract;
elsif Op_Name = Name_Op_Concat then
Kind := N_Op_Concat;
elsif Op_Name = Name_Op_Multiply then
Kind := N_Op_Multiply;
elsif Op_Name = Name_Op_Divide then
Kind := N_Op_Divide;
elsif Op_Name = Name_Op_Mod then
Kind := N_Op_Mod;
elsif Op_Name = Name_Op_Rem then
Kind := N_Op_Rem;
elsif Op_Name = Name_Op_Expon then
Kind := N_Op_Expon;
else
raise Program_Error;
end if;
-- Unary operators
else
if Op_Name = Name_Op_Add then
Kind := N_Op_Plus;
elsif Op_Name = Name_Op_Subtract then
Kind := N_Op_Minus;
elsif Op_Name = Name_Op_Abs then
Kind := N_Op_Abs;
elsif Op_Name = Name_Op_Not then
Kind := N_Op_Not;
else
raise Program_Error;
end if;
end if;
return Kind;
end Operator_Kind;
----------------------------
-- Preanalyze_And_Resolve --
----------------------------
procedure Preanalyze_And_Resolve (N : Node_Id; T : Entity_Id) is
Save_Full_Analysis : constant Boolean := Full_Analysis;
begin
Full_Analysis := False;
Expander_Mode_Save_And_Set (False);
-- Normally, we suppress all checks for this preanalysis. There is no
-- point in processing them now, since they will be applied properly
-- and in the proper location when the default expressions reanalyzed
-- and reexpanded later on. We will also have more information at that
-- point for possible suppression of individual checks.
-- However, in SPARK mode, most expansion is suppressed, and this
-- later reanalysis and reexpansion may not occur. SPARK mode does
-- require the setting of checking flags for proof purposes, so we
-- do the SPARK preanalysis without suppressing checks.
-- This special handling for SPARK mode is required for example in the
-- case of Ada 2012 constructs such as quantified expressions, which are
-- expanded in two separate steps.
if GNATprove_Mode then
Analyze_And_Resolve (N, T);
else
Analyze_And_Resolve (N, T, Suppress => All_Checks);
end if;
Expander_Mode_Restore;
Full_Analysis := Save_Full_Analysis;
end Preanalyze_And_Resolve;
-- Version without context type
procedure Preanalyze_And_Resolve (N : Node_Id) is
Save_Full_Analysis : constant Boolean := Full_Analysis;
begin
Full_Analysis := False;
Expander_Mode_Save_And_Set (False);
Analyze (N);
Resolve (N, Etype (N), Suppress => All_Checks);
Expander_Mode_Restore;
Full_Analysis := Save_Full_Analysis;
end Preanalyze_And_Resolve;
----------------------------------
-- Replace_Actual_Discriminants --
----------------------------------
procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Tsk : Node_Id := Empty;
function Process_Discr (Nod : Node_Id) return Traverse_Result;
-- Comment needed???
-------------------
-- Process_Discr --
-------------------
function Process_Discr (Nod : Node_Id) return Traverse_Result is
Ent : Entity_Id;
begin
if Nkind (Nod) = N_Identifier then
Ent := Entity (Nod);
if Present (Ent)
and then Ekind (Ent) = E_Discriminant
then
Rewrite (Nod,
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Tsk, New_Sloc => Loc),
Selector_Name => Make_Identifier (Loc, Chars (Ent))));
Set_Etype (Nod, Etype (Ent));
end if;
end if;
return OK;
end Process_Discr;
procedure Replace_Discrs is new Traverse_Proc (Process_Discr);
-- Start of processing for Replace_Actual_Discriminants
begin
if not Expander_Active then
return;
end if;
if Nkind (Name (N)) = N_Selected_Component then
Tsk := Prefix (Name (N));
elsif Nkind (Name (N)) = N_Indexed_Component then
Tsk := Prefix (Prefix (Name (N)));
end if;
if No (Tsk) then
return;
else
Replace_Discrs (Default);
end if;
end Replace_Actual_Discriminants;
-------------
-- Resolve --
-------------
procedure Resolve (N : Node_Id; Typ : Entity_Id) is
Ambiguous : Boolean := False;
Ctx_Type : Entity_Id := Typ;
Expr_Type : Entity_Id := Empty; -- prevent junk warning
Err_Type : Entity_Id := Empty;
Found : Boolean := False;
From_Lib : Boolean;
I : Interp_Index;
I1 : Interp_Index := 0; -- prevent junk warning
It : Interp;
It1 : Interp;
Seen : Entity_Id := Empty; -- prevent junk warning
function Comes_From_Predefined_Lib_Unit (Nod : Node_Id) return Boolean;
-- Determine whether a node comes from a predefined library unit or
-- Standard.
procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id);
-- Try and fix up a literal so that it matches its expected type. New
-- literals are manufactured if necessary to avoid cascaded errors.
procedure Report_Ambiguous_Argument;
-- Additional diagnostics when an ambiguous call has an ambiguous
-- argument (typically a controlling actual).
procedure Resolution_Failed;
-- Called when attempt at resolving current expression fails
------------------------------------
-- Comes_From_Predefined_Lib_Unit --
-------------------------------------
function Comes_From_Predefined_Lib_Unit (Nod : Node_Id) return Boolean is
begin
return
Sloc (Nod) = Standard_Location
or else Is_Predefined_File_Name
(Unit_File_Name (Get_Source_Unit (Sloc (Nod))));
end Comes_From_Predefined_Lib_Unit;
--------------------
-- Patch_Up_Value --
--------------------
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
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
Rewrite (N,
Make_Integer_Literal (Sloc (N),
Intval => UR_To_Uint (Realval (N))));
Set_Etype (N, Universal_Integer);
Set_Is_Static_Expression (N);
elsif Nkind (N) = N_String_Literal
and then Is_Character_Type (Typ)
then
Set_Character_Literal_Name (Char_Code (Character'Pos ('A')));
Rewrite (N,
Make_Character_Literal (Sloc (N),
Chars => Name_Find,
Char_Literal_Value =>
UI_From_Int (Character'Pos ('A'))));
Set_Etype (N, Any_Character);
Set_Is_Static_Expression (N);
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 (High_Bound (N), Typ);
end if;
end Patch_Up_Value;
-------------------------------
-- Report_Ambiguous_Argument --
-------------------------------
procedure Report_Ambiguous_Argument is
Arg : constant Node_Id := First (Parameter_Associations (N));
I : Interp_Index;
It : Interp;
begin
if Nkind (Arg) = N_Function_Call
and then Is_Entity_Name (Name (Arg))
and then Is_Overloaded (Name (Arg))
then
Error_Msg_NE ("ambiguous call to&", Arg, Name (Arg));
-- Could use comments on what is going on here???
Get_First_Interp (Name (Arg), I, It);
while Present (It.Nam) loop
Error_Msg_Sloc := Sloc (It.Nam);
if Nkind (Parent (It.Nam)) = N_Full_Type_Declaration then
Error_Msg_N ("interpretation (inherited) #!", Arg);
else
Error_Msg_N ("interpretation #!", Arg);
end if;
Get_Next_Interp (I, It);
end loop;
end if;
end Report_Ambiguous_Argument;
-----------------------
-- Resolution_Failed --
-----------------------
procedure Resolution_Failed is
begin
Patch_Up_Value (N, Typ);
Set_Etype (N, Typ);
Debug_A_Exit ("resolving ", N, " (done, resolution failed)");
Set_Is_Overloaded (N, False);
-- The caller will return without calling the expander, so we need
-- to set the analyzed flag. Note that it is fine to set Analyzed
-- to True even if we are in the middle of a shallow analysis,
-- (see the spec of sem for more details) since this is an error
-- situation anyway, and there is no point in repeating the
-- analysis later (indeed it won't work to repeat it later, since
-- we haven't got a clear resolution of which entity is being
-- referenced.)
Set_Analyzed (N, True);
return;
end Resolution_Failed;
-- Start of processing for Resolve
begin
if N = Error then
return;
end if;
-- Access attribute on remote subprogram cannot be used for a non-remote
-- access-to-subprogram type.
if Nkind (N) = N_Attribute_Reference
and then Nam_In (Attribute_Name (N), Name_Access,
Name_Unrestricted_Access,
Name_Unchecked_Access)
and then Comes_From_Source (N)
and then Is_Entity_Name (Prefix (N))
and then Is_Subprogram (Entity (Prefix (N)))
and then Is_Remote_Call_Interface (Entity (Prefix (N)))
and then not Is_Remote_Access_To_Subprogram_Type (Typ)
then
Error_Msg_N
("prefix must statically denote a non-remote subprogram", N);
end if;
From_Lib := Comes_From_Predefined_Lib_Unit (N);
-- If the context is a Remote_Access_To_Subprogram, access attributes
-- must be resolved with the corresponding fat pointer. There is no need
-- to check for the attribute name since the return type of an
-- attribute is never a remote type.
if Nkind (N) = N_Attribute_Reference
and then Comes_From_Source (N)
and then (Is_Remote_Call_Interface (Typ) or else Is_Remote_Types (Typ))
then
declare
Attr : constant Attribute_Id :=
Get_Attribute_Id (Attribute_Name (N));
Pref : constant Node_Id := Prefix (N);
Decl : Node_Id;
Spec : Node_Id;
Is_Remote : Boolean := True;
begin
-- Check that Typ is a remote access-to-subprogram type
if Is_Remote_Access_To_Subprogram_Type (Typ) then
-- Prefix (N) must statically denote a remote subprogram
-- declared in a package specification.
if Attr = Attribute_Access or else
Attr = Attribute_Unchecked_Access or else
Attr = Attribute_Unrestricted_Access
then
Decl := Unit_Declaration_Node (Entity (Pref));
if Nkind (Decl) = N_Subprogram_Body then
Spec := Corresponding_Spec (Decl);
if Present (Spec) then
Decl := Unit_Declaration_Node (Spec);
end if;
end if;
Spec := Parent (Decl);
if not Is_Entity_Name (Prefix (N))
or else Nkind (Spec) /= N_Package_Specification
or else
not Is_Remote_Call_Interface (Defining_Entity (Spec))
then
Is_Remote := False;
Error_Msg_N
("prefix must statically denote a remote subprogram ",
N);
end if;
-- If we are generating code in distributed mode, perform
-- semantic checks against corresponding remote entities.
if Expander_Active
and then Get_PCS_Name /= Name_No_DSA
then
Check_Subtype_Conformant
(New_Id => Entity (Prefix (N)),
Old_Id => Designated_Type
(Corresponding_Remote_Type (Typ)),
Err_Loc => N);
if Is_Remote then
Process_Remote_AST_Attribute (N, Typ);
end if;
end if;
end if;
end if;
end;
end if;
Debug_A_Entry ("resolving ", N);
if Debug_Flag_V then
Write_Overloads (N);
end if;
if Comes_From_Source (N) then
if Is_Fixed_Point_Type (Typ) then
Check_Restriction (No_Fixed_Point, N);
elsif Is_Floating_Point_Type (Typ)
and then Typ /= Universal_Real
and then Typ /= Any_Real
then
Check_Restriction (No_Floating_Point, N);
end if;
end if;
-- Return if already analyzed
if Analyzed (N) then
Debug_A_Exit ("resolving ", N, " (done, already analyzed)");
Analyze_Dimension (N);
return;
-- Any case of Any_Type as the Etype value means that we had a
-- previous error.
elsif Etype (N) = Any_Type then
Debug_A_Exit ("resolving ", N, " (done, Etype = Any_Type)");
return;
end if;
Check_Parameterless_Call (N);
-- The resolution of an Expression_With_Actions is determined by
-- its Expression.
if Nkind (N) = N_Expression_With_Actions then
Resolve (Expression (N), Typ);
Found := True;
Expr_Type := Etype (Expression (N));
-- If not overloaded, then we know the type, and all that needs doing
-- is to check that this type is compatible with the context.
elsif not Is_Overloaded (N) then
Found := Covers (Typ, Etype (N));
Expr_Type := Etype (N);
-- In the overloaded case, we must select the interpretation that
-- is compatible with the context (i.e. the type passed to Resolve)
else
-- Loop through possible interpretations
Get_First_Interp (N, I, It);
Interp_Loop : while Present (It.Typ) loop
if Debug_Flag_V then
Write_Str ("Interp: ");
Write_Interp (It);
end if;
-- We are only interested in interpretations that are compatible
-- with the expected type, any other interpretations are ignored.
if not Covers (Typ, It.Typ) then
if Debug_Flag_V then
Write_Str (" interpretation incompatible with context");
Write_Eol;
end if;
else
-- Skip the current interpretation if it is disabled by an
-- abstract operator. This action is performed only when the
-- type against which we are resolving is the same as the
-- type of the interpretation.
if Ada_Version >= Ada_2005
and then It.Typ = Typ
and then Typ /= Universal_Integer
and then Typ /= Universal_Real
and then Present (It.Abstract_Op)
then
if Debug_Flag_V then
Write_Line ("Skip.");
end if;
goto Continue;
end if;
-- First matching interpretation
if not Found then
Found := True;
I1 := I;
Seen := It.Nam;
Expr_Type := It.Typ;
-- Matching interpretation that is not the first, maybe an
-- error, but there are some cases where preference rules are
-- used to choose between the two possibilities. These and
-- some more obscure cases are handled in Disambiguate.
else
-- If the current statement is part of a predefined library
-- unit, then all interpretations which come from user level
-- packages should not be considered. Check previous and
-- current one.
if From_Lib then
if not Comes_From_Predefined_Lib_Unit (It.Nam) then
goto Continue;
elsif not Comes_From_Predefined_Lib_Unit (Seen) then
-- Previous interpretation must be discarded
I1 := I;
Seen := It.Nam;
Expr_Type := It.Typ;
Set_Entity (N, Seen);
goto Continue;
end if;
end if;
-- Otherwise apply further disambiguation steps
Error_Msg_Sloc := Sloc (Seen);
It1 := Disambiguate (N, I1, I, Typ);
-- Disambiguation has succeeded. Skip the remaining
-- interpretations.
if It1 /= No_Interp then
Seen := It1.Nam;
Expr_Type := It1.Typ;
while Present (It.Typ) loop
Get_Next_Interp (I, It);
end loop;
else
-- Before we issue an ambiguity complaint, check for
-- the case of a subprogram call where at least one
-- of the arguments is Any_Type, and if so, suppress
-- the message, since it is a cascaded error.
if Nkind (N) in N_Subprogram_Call then
declare
A : Node_Id;
E : Node_Id;
begin
A := First_Actual (N);
while Present (A) loop
E := A;
if Nkind (E) = N_Parameter_Association then
E := Explicit_Actual_Parameter (E);
end if;
if Etype (E) = Any_Type then
if Debug_Flag_V then
Write_Str ("Any_Type in call");
Write_Eol;
end if;
exit Interp_Loop;
end if;
Next_Actual (A);
end loop;
end;
elsif Nkind (N) in N_Binary_Op
and then (Etype (Left_Opnd (N)) = Any_Type
or else Etype (Right_Opnd (N)) = Any_Type)
then
exit Interp_Loop;
elsif Nkind (N) in N_Unary_Op
and then Etype (Right_Opnd (N)) = Any_Type
then
exit Interp_Loop;
end if;
-- Not that special case, so issue message using the
-- flag Ambiguous to control printing of the header
-- message only at the start of an ambiguous set.
if not Ambiguous then
if Nkind (N) = N_Function_Call
and then Nkind (Name (N)) = N_Explicit_Dereference
then
Error_Msg_N
("ambiguous expression "
& "(cannot resolve indirect call)!", N);
else
Error_Msg_NE -- CODEFIX
("ambiguous expression (cannot resolve&)!",
N, It.Nam);
end if;
Ambiguous := True;
if Nkind (Parent (Seen)) = N_Full_Type_Declaration then
Error_Msg_N
("\\possible interpretation (inherited)#!", N);
else
Error_Msg_N -- CODEFIX
("\\possible interpretation#!", N);
end if;
if Nkind (N) in N_Subprogram_Call
and then Present (Parameter_Associations (N))
then
Report_Ambiguous_Argument;
end if;
end if;
Error_Msg_Sloc := Sloc (It.Nam);
-- By default, the error message refers to the candidate
-- interpretation. But if it is a predefined operator, it
-- is implicitly declared at the declaration of the type
-- of the operand. Recover the sloc of that declaration
-- for the error message.
if Nkind (N) in N_Op
and then Scope (It.Nam) = Standard_Standard
and then not Is_Overloaded (Right_Opnd (N))
and then Scope (Base_Type (Etype (Right_Opnd (N)))) /=
Standard_Standard
then
Err_Type := First_Subtype (Etype (Right_Opnd (N)));
if Comes_From_Source (Err_Type)
and then Present (Parent (Err_Type))
then
Error_Msg_Sloc := Sloc (Parent (Err_Type));
end if;
elsif Nkind (N) in N_Binary_Op
and then Scope (It.Nam) = Standard_Standard
and then not Is_Overloaded (Left_Opnd (N))
and then Scope (Base_Type (Etype (Left_Opnd (N)))) /=
Standard_Standard
then
Err_Type := First_Subtype (Etype (Left_Opnd (N)));
if Comes_From_Source (Err_Type)
and then Present (Parent (Err_Type))
then
Error_Msg_Sloc := Sloc (Parent (Err_Type));
end if;
-- If this is an indirect call, use the subprogram_type
-- in the message, to have a meaningful location. Also
-- indicate if this is an inherited operation, created
-- by a type declaration.
elsif Nkind (N) = N_Function_Call
and then Nkind (Name (N)) = N_Explicit_Dereference
and then Is_Type (It.Nam)
then
Err_Type := It.Nam;
Error_Msg_Sloc :=
Sloc (Associated_Node_For_Itype (Err_Type));
else
Err_Type := Empty;
end if;
if Nkind (N) in N_Op
and then Scope (It.Nam) = Standard_Standard
and then Present (Err_Type)
then
-- Special-case the message for universal_fixed
-- operators, which are not declared with the type
-- of the operand, but appear forever in Standard.
if It.Typ = Universal_Fixed
and then Scope (It.Nam) = Standard_Standard
then
Error_Msg_N
("\\possible interpretation as universal_fixed "
& "operation (RM 4.5.5 (19))", N);
else
Error_Msg_N
("\\possible interpretation (predefined)#!", N);
end if;
elsif
Nkind (Parent (It.Nam)) = N_Full_Type_Declaration
then
Error_Msg_N
("\\possible interpretation (inherited)#!", N);
else
Error_Msg_N -- CODEFIX
("\\possible interpretation#!", N);
end if;
end if;
end if;
-- We have a matching interpretation, Expr_Type is the type
-- from this interpretation, and Seen is the entity.
-- For an operator, just set the entity name. The type will be
-- set by the specific operator resolution routine.
if Nkind (N) in N_Op then
Set_Entity (N, Seen);
Generate_Reference (Seen, N);
elsif Nkind (N) = N_Case_Expression then
Set_Etype (N, Expr_Type);
elsif Nkind (N) = N_Character_Literal then
Set_Etype (N, Expr_Type);
elsif Nkind (N) = N_If_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
-- If the node is a general indexing, the dereference is
-- is inserted when resolving the rewritten form, else
-- insert it now.
if Nkind (N) /= N_Indexed_Component
or else No (Generalized_Indexing (N))
then
Build_Explicit_Dereference (N, It.Nam);
end if;
-- 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
-- nothing to be done at this point.
elsif Nkind_In (N, N_Explicit_Dereference,
N_Attribute_Reference,
N_And_Then,
N_Indexed_Component,
N_Or_Else,
N_Range,
N_Selected_Component,
N_Slice)
or else Nkind (Name (N)) = N_Explicit_Dereference
then
null;
-- For procedure or function calls, set the type of the name,
-- and also the entity pointer for the prefix.
elsif Nkind (N) in N_Subprogram_Call
and then Is_Entity_Name (Name (N))
then
Set_Etype (Name (N), Expr_Type);
Set_Entity (Name (N), Seen);
Generate_Reference (Seen, Name (N));
elsif Nkind (N) = N_Function_Call
and then Nkind (Name (N)) = N_Selected_Component
then
Set_Etype (Name (N), Expr_Type);
Set_Entity (Selector_Name (Name (N)), Seen);
Generate_Reference (Seen, Selector_Name (Name (N)));
-- For all other cases, just set the type of the Name
else
Set_Etype (Name (N), Expr_Type);
end if;
end if;
<<Continue>>
-- Move to next interpretation
exit Interp_Loop when No (It.Typ);
Get_Next_Interp (I, It);
end loop Interp_Loop;
end if;
-- At this stage Found indicates whether or not an acceptable
-- interpretation exists. If not, then we have an error, except that if
-- the context is Any_Type as a result of some other error, then we
-- suppress the error report.
if not Found then
if Typ /= Any_Type then
-- If type we are looking for is Void, then this is the procedure
-- call case, and the error is simply that what we gave is not a
-- procedure name (we think of procedure calls as expressions with
-- types internally, but the user doesn't think of them this way).
if Typ = Standard_Void_Type then
-- Special case message if function used as a procedure
if Nkind (N) = N_Procedure_Call_Statement
and then Is_Entity_Name (Name (N))
and then Ekind (Entity (Name (N))) = E_Function
then
Error_Msg_NE
("cannot use function & in a procedure call",
Name (N), Entity (Name (N)));
-- Otherwise give general message (not clear what cases this
-- covers, but no harm in providing for them).
else
Error_Msg_N ("expect procedure name in procedure call", N);
end if;
Found := True;
-- Otherwise we do have a subexpression with the wrong type
-- Check for the case of an allocator which uses an access type
-- instead of the designated type. This is a common error and we
-- specialize the message, posting an error on the operand of the
-- allocator, complaining that we expected the designated type of
-- the allocator.
elsif Nkind (N) = N_Allocator
and then Is_Access_Type (Typ)
and then Is_Access_Type (Etype (N))
and then Designated_Type (Etype (N)) = Typ
then
Wrong_Type (Expression (N), Designated_Type (Typ));
Found := True;
-- Check for view mismatch on Null in instances, for which the
-- view-swapping mechanism has no identifier.
elsif (In_Instance or else In_Inlined_Body)
and then (Nkind (N) = N_Null)
and then Is_Private_Type (Typ)
and then Is_Access_Type (Full_View (Typ))
then
Resolve (N, Full_View (Typ));
Set_Etype (N, Typ);
return;
-- Check for an aggregate. Sometimes we can get bogus aggregates
-- from misuse of parentheses, and we are about to complain about
-- the aggregate without even looking inside it.
-- Instead, if we have an aggregate of type Any_Composite, then
-- analyze and resolve the component fields, and then only issue
-- another message if we get no errors doing this (otherwise
-- assume that the errors in the aggregate caused the problem).
elsif Nkind (N) = N_Aggregate
and then Etype (N) = Any_Composite
then
-- Disable expansion in any case. If there is a type mismatch
-- it may be fatal to try to expand the aggregate. The flag
-- would otherwise be set to false when the error is posted.
Expander_Active := False;
declare
procedure Check_Aggr (Aggr : Node_Id);
-- Check one aggregate, and set Found to True if we have a
-- definite error in any of its elements
procedure Check_Elmt (Aelmt : Node_Id);
-- Check one element of aggregate and set Found to True if
-- we definitely have an error in the element.
----------------
-- Check_Aggr --
----------------
procedure Check_Aggr (Aggr : Node_Id) is
Elmt : Node_Id;
begin
if Present (Expressions (Aggr)) then
Elmt := First (Expressions (Aggr));
while Present (Elmt) loop
Check_Elmt (Elmt);
Next (Elmt);
end loop;
end if;
if Present (Component_Associations (Aggr)) then
Elmt := First (Component_Associations (Aggr));
while Present (Elmt) loop
-- If this is a default-initialized component, then
-- there is nothing to check. The box will be
-- replaced by the appropriate call during late
-- expansion.
if not Box_Present (Elmt) then
Check_Elmt (Expression (Elmt));
end if;
Next (Elmt);
end loop;
end if;
end Check_Aggr;
----------------
-- Check_Elmt --
----------------
procedure Check_Elmt (Aelmt : Node_Id) is
begin
-- If we have a nested aggregate, go inside it (to
-- attempt a naked analyze-resolve of the aggregate can
-- cause undesirable cascaded errors). Do not resolve
-- expression if it needs a type from context, as for
-- integer * fixed expression.
if Nkind (Aelmt) = N_Aggregate then
Check_Aggr (Aelmt);
else
Analyze (Aelmt);
if not Is_Overloaded (Aelmt)
and then Etype (Aelmt) /= Any_Fixed
then
Resolve (Aelmt);
end if;
if Etype (Aelmt) = Any_Type then
Found := True;
end if;
end if;
end Check_Elmt;
begin
Check_Aggr (N);
end;
end if;
-- Looks like we have a type error, but check for special case
-- of Address wanted, integer found, with the configuration pragma
-- Allow_Integer_Address active. If we have this case, introduce
-- an unchecked conversion to allow the integer expression to be
-- treated as an Address. The reverse case of integer wanted,
-- Address found, is treated in an analogous manner.
if Address_Integer_Convert_OK (Typ, Etype (N)) then
Rewrite (N, Unchecked_Convert_To (Typ, Relocate_Node (N)));
Analyze_And_Resolve (N, Typ);
return;
end if;
-- That special Allow_Integer_Address check did not appply, so we
-- have a real type error. If an error message was issued already,
-- Found got reset to True, so if it's still False, issue standard
-- Wrong_Type message.
if not Found then
if Is_Overloaded (N) and then Nkind (N) = N_Function_Call then
declare
Subp_Name : Node_Id;
begin
if Is_Entity_Name (Name (N)) then
Subp_Name := Name (N);
elsif Nkind (Name (N)) = N_Selected_Component then
-- Protected operation: retrieve operation name
Subp_Name := Selector_Name (Name (N));
else
raise Program_Error;
end if;
Error_Msg_Node_2 := Typ;
Error_Msg_NE
("no visible interpretation of& "
& "matches expected type&", N, Subp_Name);
end;
if All_Errors_Mode then
declare
Index : Interp_Index;
It : Interp;
begin
Error_Msg_N ("\\possible interpretations:", N);
Get_First_Interp (Name (N), Index, It);
while Present (It.Nam) loop
Error_Msg_Sloc := Sloc (It.Nam);
Error_Msg_Node_2 := It.Nam;
Error_Msg_NE
("\\ type& for & declared#", N, It.Typ);
Get_Next_Interp (Index, It);
end loop;
end;
else
Error_Msg_N ("\use -gnatf for details", N);
end if;
else
Wrong_Type (N, Typ);
end if;
end if;
end if;
Resolution_Failed;
return;
-- Test if we have more than one interpretation for the context
elsif Ambiguous then
Resolution_Failed;
return;
-- Only one intepretation
else
-- In Ada 2005, if we have something like "X : T := 2 + 2;", where
-- the "+" on T is abstract, and the operands are of universal type,
-- the above code will have (incorrectly) resolved the "+" to the
-- universal one in Standard. Therefore check for this case and give
-- an error. We can't do this earlier, because it would cause legal
-- cases to get errors (when some other type has an abstract "+").
if Ada_Version >= Ada_2005
and then Nkind (N) in N_Op
and then Is_Overloaded (N)
and then Is_Universal_Numeric_Type (Etype (Entity (N)))
then
Get_First_Interp (N, I, It);
while Present (It.Typ) loop
if Present (It.Abstract_Op) and then
Etype (It.Abstract_Op) = Typ
then
Error_Msg_NE
("cannot call abstract subprogram &!", N, It.Abstract_Op);
return;
end if;
Get_Next_Interp (I, It);
end loop;
end if;
-- Here we have an acceptable interpretation for the context
-- Propagate type information and normalize tree for various
-- predefined operations. If the context only imposes a class of
-- types, rather than a specific type, propagate the actual type
-- downward.
if Typ = Any_Integer or else
Typ = Any_Boolean or else
Typ = Any_Modular or else
Typ = Any_Real or else
Typ = Any_Discrete
then
Ctx_Type := Expr_Type;
-- Any_Fixed is legal in a real context only if a specific fixed-
-- point type is imposed. If Norman Cohen can be confused by this,
-- it deserves a separate message.
if Typ = Any_Real
and then Expr_Type = Any_Fixed
then
Error_Msg_N ("illegal context for mixed mode operation", N);
Set_Etype (N, Universal_Real);
Ctx_Type := Universal_Real;
end if;
end if;
-- A user-defined operator is transformed into a function call at
-- this point, so that further processing knows that operators are
-- really operators (i.e. are predefined operators). User-defined
-- operators that are intrinsic are just renamings of the predefined
-- ones, and need not be turned into calls either, but if they rename
-- a different operator, we must transform the node accordingly.
-- Instantiations of Unchecked_Conversion are intrinsic but are
-- treated as functions, even if given an operator designator.
if Nkind (N) in N_Op
and then Present (Entity (N))
and then Ekind (Entity (N)) /= E_Operator
then
if not Is_Predefined_Op (Entity (N)) then
Rewrite_Operator_As_Call (N, Entity (N));
elsif Present (Alias (Entity (N)))
and then
Nkind (Parent (Parent (Entity (N)))) =
N_Subprogram_Renaming_Declaration
then
Rewrite_Renamed_Operator (N, Alias (Entity (N)), Typ);
-- If the node is rewritten, it will be fully resolved in
-- Rewrite_Renamed_Operator.
if Analyzed (N) then
return;
end if;
end if;
end if;
case N_Subexpr'(Nkind (N)) is
when N_Aggregate => Resolve_Aggregate (N, Ctx_Type);
when N_Allocator => Resolve_Allocator (N, Ctx_Type);
when N_Short_Circuit
=> Resolve_Short_Circuit (N, Ctx_Type);
when N_Attribute_Reference
=> Resolve_Attribute (N, Ctx_Type);
when N_Case_Expression
=> Resolve_Case_Expression (N, Ctx_Type);
when N_Character_Literal
=> Resolve_Character_Literal (N, Ctx_Type);
when N_Expanded_Name
=> Resolve_Entity_Name (N, Ctx_Type);
when N_Explicit_Dereference
=> Resolve_Explicit_Dereference (N, Ctx_Type);
when N_Expression_With_Actions
=> Resolve_Expression_With_Actions (N, Ctx_Type);
when N_Extension_Aggregate
=> Resolve_Extension_Aggregate (N, Ctx_Type);
when N_Function_Call
=> Resolve_Call (N, Ctx_Type);
when N_Identifier
=> Resolve_Entity_Name (N, Ctx_Type);
when N_If_Expression
=> Resolve_If_Expression (N, Ctx_Type);
when N_Indexed_Component
=> Resolve_Indexed_Component (N, Ctx_Type);
when N_Integer_Literal
=> Resolve_Integer_Literal (N, Ctx_Type);
when N_Membership_Test
=> Resolve_Membership_Op (N, Ctx_Type);
when N_Null => Resolve_Null (N, Ctx_Type);
when N_Op_And | N_Op_Or | N_Op_Xor
=> Resolve_Logical_Op (N, Ctx_Type);
when N_Op_Eq | N_Op_Ne
=> Resolve_Equality_Op (N, Ctx_Type);
when N_Op_Lt | N_Op_Le | N_Op_Gt | N_Op_Ge
=> Resolve_Comparison_Op (N, Ctx_Type);
when N_Op_Not => Resolve_Op_Not (N, Ctx_Type);
when N_Op_Add | N_Op_Subtract | N_Op_Multiply |
N_Op_Divide | N_Op_Mod | N_Op_Rem
=> Resolve_Arithmetic_Op (N, Ctx_Type);
when N_Op_Concat => Resolve_Op_Concat (N, Ctx_Type);
when N_Op_Expon => Resolve_Op_Expon (N, Ctx_Type);
when N_Op_Plus | N_Op_Minus | N_Op_Abs
=> Resolve_Unary_Op (N, Ctx_Type);
when N_Op_Shift => Resolve_Shift (N, Ctx_Type);
when N_Procedure_Call_Statement
=> Resolve_Call (N, Ctx_Type);
when N_Operator_Symbol
=> Resolve_Operator_Symbol (N, Ctx_Type);
when N_Qualified_Expression
=> Resolve_Qualified_Expression (N, Ctx_Type);
-- Why is the following null, needs a comment ???
when N_Quantified_Expression
=> null;
when N_Raise_Expression
=> Resolve_Raise_Expression (N, Ctx_Type);
when N_Raise_xxx_Error
=> Set_Etype (N, Ctx_Type);
when N_Range => Resolve_Range (N, Ctx_Type);
when N_Real_Literal
=> Resolve_Real_Literal (N, Ctx_Type);
when N_Reference => Resolve_Reference (N, Ctx_Type);
when N_Selected_Component
=> Resolve_Selected_Component (N, Ctx_Type);
when N_Slice => Resolve_Slice (N, Ctx_Type);
when N_String_Literal
=> Resolve_String_Literal (N, Ctx_Type);
when N_Type_Conversion
=> Resolve_Type_Conversion (N, Ctx_Type);
when N_Unchecked_Expression =>
Resolve_Unchecked_Expression (N, Ctx_Type);
when N_Unchecked_Type_Conversion =>
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,
-- but there may be others, so we are making this test general.
if Nkind (N) not in N_Subexpr then
Debug_A_Exit ("resolving ", N, " (done)");
Expand (N);
return;
end if;
-- The expression is definitely NOT overloaded at this point, so
-- we reset the Is_Overloaded flag to avoid any confusion when
-- reanalyzing the node.
Set_Is_Overloaded (N, False);
-- Freeze expression type, entity if it is a name, and designated
-- type if it is an allocator (RM 13.14(10,11,13)).
-- Now that the resolution of the type of the node is complete, and
-- we did not detect an error, we can expand this node. We skip the
-- expand call if we are in a default expression, see section
-- "Handling of Default Expressions" in Sem spec.
Debug_A_Exit ("resolving ", N, " (done)");
-- We unconditionally freeze the expression, even if we are in
-- default expression mode (the Freeze_Expression routine tests this
-- flag and only freezes static types if it is set).
-- Ada 2012 (AI05-177): The declaration of an expression function
-- does not cause freezing, but we never reach here in that case.
-- Here we are resolving the corresponding expanded body, so we do
-- need to perform normal freezing.
Freeze_Expression (N);
-- Now we can do the expansion
Expand (N);
end if;
end Resolve;
-------------
-- Resolve --
-------------
-- Version with check(s) suppressed
procedure Resolve (N : Node_Id; Typ : Entity_Id; Suppress : Check_Id) is
begin
if Suppress = All_Checks then
declare
Sva : constant Suppress_Array := Scope_Suppress.Suppress;
begin
Scope_Suppress.Suppress := (others => True);
Resolve (N, Typ);
Scope_Suppress.Suppress := Sva;
end;
else
declare
Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
begin
Scope_Suppress.Suppress (Suppress) := True;
Resolve (N, Typ);
Scope_Suppress.Suppress (Suppress) := Svg;
end;
end if;
end Resolve;
-------------
-- Resolve --
-------------
-- Version with implicit type
procedure Resolve (N : Node_Id) is
begin
Resolve (N, Etype (N));
end Resolve;
---------------------
-- Resolve_Actuals --
---------------------
procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
A : Node_Id;
A_Id : Entity_Id;
A_Typ : Entity_Id;
F : Entity_Id;
F_Typ : Entity_Id;
Prev : Node_Id := Empty;
Orig_A : Node_Id;
procedure Check_Aliased_Parameter;
-- Check rules on aliased parameters and related accessibility rules
-- in (RM 3.10.2 (10.2-10.4)).
procedure Check_Argument_Order;
-- Performs a check for the case where the actuals are all simple
-- identifiers that correspond to the formal names, but in the wrong
-- order, which is considered suspicious and cause for a warning.
procedure Check_Prefixed_Call;
-- If the original node is an overloaded call in prefix notation,
-- insert an 'Access or a dereference as needed over the first actual.
-- Try_Object_Operation has already verified that there is a valid
-- interpretation, but the form of the actual can only be determined
-- once the primitive operation is identified.
procedure Insert_Default;
-- If the actual is missing in a call, insert in the actuals list
-- an instance of the default expression. The insertion is always
-- a named association.
procedure Property_Error
(Var : Node_Id;
Var_Id : Entity_Id;
Prop_Nam : Name_Id);
-- Emit an error concerning variable Var with entity Var_Id that has
-- enabled property Prop_Nam when it acts as an actual parameter in a
-- call and the corresponding formal parameter is of mode IN.
function Same_Ancestor (T1, T2 : Entity_Id) return Boolean;
-- Check whether T1 and T2, or their full views, are derived from a
-- common type. Used to enforce the restrictions on array conversions
-- of AI95-00246.
function Static_Concatenation (N : Node_Id) return Boolean;
-- Predicate to determine whether an actual that is a concatenation
-- will be evaluated statically and does not need a transient scope.
-- This must be determined before the actual is resolved and expanded
-- because if needed the transient scope must be introduced earlier.
-----------------------------
-- Check_Aliased_Parameter --
-----------------------------
procedure Check_Aliased_Parameter is
Nominal_Subt : Entity_Id;
begin
if Is_Aliased (F) then
if Is_Tagged_Type (A_Typ) then
null;
elsif Is_Aliased_View (A) then
if Is_Constr_Subt_For_U_Nominal (A_Typ) then
Nominal_Subt := Base_Type (A_Typ);
else
Nominal_Subt := A_Typ;
end if;
if Subtypes_Statically_Match (F_Typ, Nominal_Subt) then
null;
-- In a generic body assume the worst for generic formals:
-- they can have a constrained partial view (AI05-041).
elsif Has_Discriminants (F_Typ)
and then not Is_Constrained (F_Typ)
and then not Has_Constrained_Partial_View (F_Typ)
and then not Is_Generic_Type (F_Typ)
then
null;
else
Error_Msg_NE ("untagged actual does not match "
& "aliased formal&", A, F);
end if;
else
Error_Msg_NE ("actual for aliased formal& must be "
& "aliased object", A, F);
end if;
if Ekind (Nam) = E_Procedure then
null;
elsif Ekind (Etype (Nam)) = E_Anonymous_Access_Type then
if Nkind (Parent (N)) = N_Type_Conversion
and then Type_Access_Level (Etype (Parent (N))) <
Object_Access_Level (A)
then
Error_Msg_N ("aliased actual has wrong accessibility", A);
end if;
elsif Nkind (Parent (N)) = N_Qualified_Expression
and then Nkind (Parent (Parent (N))) = N_Allocator
and then Type_Access_Level (Etype (Parent (Parent (N)))) <
Object_Access_Level (A)
then
Error_Msg_N
("aliased actual in allocator has wrong accessibility", A);
end if;
end if;
end Check_Aliased_Parameter;
--------------------------
-- Check_Argument_Order --
--------------------------
procedure Check_Argument_Order is
begin
-- Nothing to do if no parameters, or original node is neither a
-- function call nor a procedure call statement (happens in the
-- operator-transformed-to-function call case), or the call does
-- not come from source, or this warning is off.
if not Warn_On_Parameter_Order
or else No (Parameter_Associations (N))
or else Nkind (Original_Node (N)) not in N_Subprogram_Call
or else not Comes_From_Source (N)
then
return;
end if;
declare
Nargs : constant Nat := List_Length (Parameter_Associations (N));
begin
-- Nothing to do if only one parameter
if Nargs < 2 then
return;
end if;
-- Here if at least two arguments
declare
Actuals : array (1 .. Nargs) of Node_Id;
Actual : Node_Id;
Formal : Node_Id;
Wrong_Order : Boolean := False;
-- Set True if an out of order case is found
begin
-- Collect identifier names of actuals, fail if any actual is
-- not a simple identifier, and record max length of name.
Actual := First (Parameter_Associations (N));
for J in Actuals'Range loop
if Nkind (Actual) /= N_Identifier then
return;
else
Actuals (J) := Actual;
Next (Actual);
end if;
end loop;
-- If we got this far, all actuals are identifiers and the list
-- of their names is stored in the Actuals array.
Formal := First_Formal (Nam);
for J in Actuals'Range loop
-- If we ran out of formals, that's odd, probably an error
-- which will be detected elsewhere, but abandon the search.
if No (Formal) then
return;
end if;
-- If name matches and is in order OK
if Chars (Formal) = Chars (Actuals (J)) then
null;
else
-- If no match, see if it is elsewhere in list and if so
-- flag potential wrong order if type is compatible.
for K in Actuals'Range loop
if Chars (Formal) = Chars (Actuals (K))
and then
Has_Compatible_Type (Actuals (K), Etype (Formal))
then
Wrong_Order := True;
goto Continue;
end if;
end loop;
-- No match
return;
end if;
<<Continue>> Next_Formal (Formal);
end loop;
-- If Formals left over, also probably an error, skip warning
if Present (Formal) then
return;
end if;
-- Here we give the warning if something was out of order
if Wrong_Order then
Error_Msg_N
("?P?actuals for this call may be in wrong order", N);
end if;
end;
end;
end Check_Argument_Order;
-------------------------
-- Check_Prefixed_Call --
-------------------------
procedure Check_Prefixed_Call is
Act : constant Node_Id := First_Actual (N);
A_Type : constant Entity_Id := Etype (Act);
F_Type : constant Entity_Id := Etype (First_Formal (Nam));
Orig : constant Node_Id := Original_Node (N);
New_A : Node_Id;
begin
-- Check whether the call is a prefixed call, with or without
-- additional actuals.
if Nkind (Orig) = N_Selected_Component
or else
(Nkind (Orig) = N_Indexed_Component
and then Nkind (Prefix (Orig)) = N_Selected_Component
and then Is_Entity_Name (Prefix (Prefix (Orig)))
and then Is_Entity_Name (Act)
and then Chars (Act) = Chars (Prefix (Prefix (Orig))))
then
if Is_Access_Type (A_Type)
and then not Is_Access_Type (F_Type)
then
-- Introduce dereference on object in prefix
New_A :=
Make_Explicit_Dereference (Sloc (Act),
Prefix => Relocate_Node (Act));
Rewrite (Act, New_A);
Analyze (Act);
elsif Is_Access_Type (F_Type)
and then not Is_Access_Type (A_Type)
then
-- Introduce an implicit 'Access in prefix
if not Is_Aliased_View (Act) then
Error_Msg_NE
("object in prefixed call to& must be aliased "
& "(RM 4.1.3 (13 1/2))",
Prefix (Act), Nam);
end if;
Rewrite (Act,
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Access,
Prefix => Relocate_Node (Act)));
end if;
Analyze (Act);
end if;
end Check_Prefixed_Call;
--------------------
-- Insert_Default --
--------------------
procedure Insert_Default is
Actval : Node_Id;
Assoc : Node_Id;
begin
-- Missing argument in call, nothing to insert
if No (Default_Value (F)) then
return;
else
-- Note that we do a full New_Copy_Tree, so that any associated
-- Itypes are properly copied. This may not be needed any more,
-- but it does no harm as a safety measure. Defaults of a generic
-- formal may be out of bounds of the corresponding actual (see
-- cc1311b) and an additional check may be required.
Actval :=
New_Copy_Tree
(Default_Value (F),
New_Scope => Current_Scope,
New_Sloc => Loc);
if Is_Concurrent_Type (Scope (Nam))
and then Has_Discriminants (Scope (Nam))
then
Replace_Actual_Discriminants (N, Actval);
end if;
if Is_Overloadable (Nam)
and then Present (Alias (Nam))
then
if Base_Type (Etype (F)) /= Base_Type (Etype (Actval))
and then not Is_Tagged_Type (Etype (F))
then
-- If default is a real literal, do not introduce a
-- conversion whose effect may depend on the run-time
-- size of universal real.
if Nkind (Actval) = N_Real_Literal then
Set_Etype (Actval, Base_Type (Etype (F)));
else
Actval := Unchecked_Convert_To (Etype (F), Actval);
end if;
end if;
if Is_Scalar_Type (Etype (F)) then
Enable_Range_Check (Actval);
end if;
Set_Parent (Actval, N);
-- Resolve aggregates with their base type, to avoid scope
-- anomalies: the subtype was first built in the subprogram
-- declaration, and the current call may be nested.
if Nkind (Actval) = N_Aggregate then
Analyze_And_Resolve (Actval, Etype (F));
else
Analyze_And_Resolve (Actval, Etype (Actval));
end if;
else
Set_Parent (Actval, N);
-- See note above concerning aggregates
if Nkind (Actval) = N_Aggregate
and then Has_Discriminants (Etype (Actval))
then
Analyze_And_Resolve (Actval, Base_Type (Etype (Actval)));
-- Resolve entities with their own type, which may differ from
-- the type of a reference in a generic context (the view
-- swapping mechanism did not anticipate the re-analysis of
-- default values in calls).
elsif Is_Entity_Name (Actval) then
Analyze_And_Resolve (Actval, Etype (Entity (Actval)));
else
Analyze_And_Resolve (Actval, Etype (Actval));
end if;
end if;
-- If default is a tag indeterminate function call, propagate tag
-- to obtain proper dispatching.
if Is_Controlling_Formal (F)
and then Nkind (Default_Value (F)) = N_Function_Call
then
Set_Is_Controlling_Actual (Actval);
end if;
end if;
-- If the default expression raises constraint error, then just
-- silently replace it with an N_Raise_Constraint_Error node, since
-- we already gave the warning on the subprogram spec. If node is
-- already a Raise_Constraint_Error leave as is, to prevent loops in
-- the warnings removal machinery.
if Raises_Constraint_Error (Actval)
and then Nkind (Actval) /= N_Raise_Constraint_Error
then
Rewrite (Actval,
Make_Raise_Constraint_Error (Loc,
Reason => CE_Range_Check_Failed));
Set_Raises_Constraint_Error (Actval);
Set_Etype (Actval, Etype (F));
end if;
Assoc :=
Make_Parameter_Association (Loc,
Explicit_Actual_Parameter => Actval,
Selector_Name => Make_Identifier (Loc, Chars (F)));
-- Case of insertion is first named actual
if No (Prev) or else
Nkind (Parent (Prev)) /= N_Parameter_Association
then
Set_Next_Named_Actual (Assoc, First_Named_Actual (N));
Set_First_Named_Actual (N, Actval);
if No (Prev) then
if No (Parameter_Associations (N)) then
Set_Parameter_Associations (N, New_List (Assoc));
else
Append (Assoc, Parameter_Associations (N));
end if;
else
Insert_After (Prev, Assoc);
end if;
-- Case of insertion is not first named actual
else
Set_Next_Named_Actual
(Assoc, Next_Named_Actual (Parent (Prev)));
Set_Next_Named_Actual (Parent (Prev), Actval);
Append (Assoc, Parameter_Associations (N));
end if;
Mark_Rewrite_Insertion (Assoc);
Mark_Rewrite_Insertion (Actval);
Prev := Actval;
end Insert_Default;
--------------------
-- Property_Error --
--------------------
procedure Property_Error
(Var : Node_Id;
Var_Id : Entity_Id;
Prop_Nam : Name_Id)
is
begin
Error_Msg_Name_1 := Prop_Nam;
Error_Msg_NE
("external variable & with enabled property % cannot appear as "
& "actual in procedure call (SPARK RM 7.1.3(11))", Var, Var_Id);
Error_Msg_N ("\\corresponding formal parameter has mode In", Var);
end Property_Error;
-------------------
-- Same_Ancestor --
-------------------
function Same_Ancestor (T1, T2 : Entity_Id) return Boolean is
FT1 : Entity_Id := T1;
FT2 : Entity_Id := T2;
begin
if Is_Private_Type (T1)
and then Present (Full_View (T1))
then
FT1 := Full_View (T1);
end if;
if Is_Private_Type (T2)
and then Present (Full_View (T2))
then
FT2 := Full_View (T2);
end if;
return Root_Type (Base_Type (FT1)) = Root_Type (Base_Type (FT2));
end Same_Ancestor;
--------------------------
-- Static_Concatenation --
--------------------------
function Static_Concatenation (N : Node_Id) return Boolean is
begin
case Nkind (N) is
when N_String_Literal =>
return True;
when N_Op_Concat =>
-- Concatenation is static when both operands are static and
-- the concatenation operator is a predefined one.
return Scope (Entity (N)) = Standard_Standard
and then
Static_Concatenation (Left_Opnd (N))
and then
Static_Concatenation (Right_Opnd (N));
when others =>
if Is_Entity_Name (N) then
declare
Ent : constant Entity_Id := Entity (N);
begin
return Ekind (Ent) = E_Constant
and then Present (Constant_Value (Ent))
and then
Is_OK_Static_Expression (Constant_Value (Ent));
end;
else
return False;
end if;
end case;
end Static_Concatenation;
-- Start of processing for Resolve_Actuals
begin
Check_Argument_Order;
Check_Function_Writable_Actuals (N);
if Present (First_Actual (N)) then
Check_Prefixed_Call;
end if;
A := First_Actual (N);
F := First_Formal (Nam);
while Present (F) loop
if No (A) and then Needs_No_Actuals (Nam) then
null;
-- If we have an error in any actual or formal, indicated by a type
-- of Any_Type, then abandon resolution attempt, and set result type
-- to Any_Type. Skip this if the actual is a Raise_Expression, whose
-- type is imposed from context.
elsif (Present (A) and then Etype (A) = Any_Type)
or else Etype (F) = Any_Type
then
if Nkind (A) /= N_Raise_Expression then
Set_Etype (N, Any_Type);
return;
end if;
end if;
-- Case where actual is present
-- If the actual is an entity, generate a reference to it now. We
-- do this before the actual is resolved, because a formal of some
-- protected subprogram, or a task discriminant, will be rewritten
-- during expansion, and the source entity reference may be lost.
if Present (A)
and then Is_Entity_Name (A)
and then Comes_From_Source (N)
then
Orig_A := Entity (A);
if Present (Orig_A) then
if Is_Formal (Orig_A)
and then Ekind (F) /= E_In_Parameter
then
Generate_Reference (Orig_A, A, 'm');
elsif not Is_Overloaded (A) then
if Ekind (F) /= E_Out_Parameter then
Generate_Reference (Orig_A, A);
-- RM 6.4.1(12): For an out parameter that is passed by
-- copy, the formal parameter object is created, and:
-- * For an access type, the formal parameter is initialized
-- from the value of the actual, without checking that the
-- value satisfies any constraint, any predicate, or any
-- exclusion of the null value.
-- * For a scalar type that has the Default_Value aspect
-- specified, the formal parameter is initialized from the
-- value of the actual, without checking that the value
-- satisfies any constraint or any predicate.
-- I do not understand why this case is included??? this is
-- not a case where an OUT parameter is treated as IN OUT.
-- * For a composite type with discriminants or that has
-- implicit initial values for any subcomponents, the
-- behavior is as for an in out parameter passed by copy.
-- Hence for these cases we generate the read reference now
-- (the write reference will be generated later by
-- Note_Possible_Modification).
elsif Is_By_Copy_Type (Etype (F))
and then
(Is_Access_Type (Etype (F))
or else
(Is_Scalar_Type (Etype (F))
and then
Present (Default_Aspect_Value (Etype (F))))
or else
(Is_Composite_Type (Etype (F))
and then (Has_Discriminants (Etype (F))
or else Is_Partially_Initialized_Type
(Etype (F)))))
then
Generate_Reference (Orig_A, A);
end if;
end if;
end if;
end if;
if Present (A)
and then (Nkind (Parent (A)) /= N_Parameter_Association
or else Chars (Selector_Name (Parent (A))) = Chars (F))
then
-- If style checking mode on, check match of formal name
if Style_Check then
if Nkind (Parent (A)) = N_Parameter_Association then
Check_Identifier (Selector_Name (Parent (A)), F);
end if;
end if;
-- If the formal is Out or In_Out, do not resolve and expand the
-- conversion, because it is subsequently expanded into explicit
-- temporaries and assignments. However, the object of the
-- conversion can be resolved. An exception is the case of tagged
-- type conversion with a class-wide actual. In that case we want
-- the tag check to occur and no temporary will be needed (no
-- representation change can occur) and the parameter is passed by
-- reference, so we go ahead and resolve the type conversion.
-- Another exception is the case of reference to component or
-- subcomponent of a bit-packed array, in which case we want to
-- defer expansion to the point the in and out assignments are
-- performed.
if Ekind (F) /= E_In_Parameter
and then Nkind (A) = N_Type_Conversion
and then not Is_Class_Wide_Type (Etype (Expression (A)))
then
if Ekind (F) = E_In_Out_Parameter
and then Is_Array_Type (Etype (F))
then
-- In a view conversion, the conversion must be legal in
-- both directions, and thus both component types must be
-- aliased, or neither (4.6 (8)).
-- The extra rule in 4.6 (24.9.2) seems unduly restrictive:
-- the privacy requirement should not apply to generic
-- types, and should be checked in an instance. ARG query
-- is in order ???
if Has_Aliased_Components (Etype (Expression (A))) /=
Has_Aliased_Components (Etype (F))
then
Error_Msg_N
("both component types in a view conversion must be"
& " aliased, or neither", A);
-- Comment here??? what set of cases???
elsif
not Same_Ancestor (Etype (F), Etype (Expression (A)))
then
-- Check view conv between unrelated by ref array types
if Is_By_Reference_Type (Etype (F))
or else Is_By_Reference_Type (Etype (Expression (A)))
then
Error_Msg_N
("view conversion between unrelated by reference "
& "array types not allowed (\'A'I-00246)", A);
-- In Ada 2005 mode, check view conversion component
-- type cannot be private, tagged, or volatile. Note
-- that we only apply this to source conversions. The
-- generated code can contain conversions which are
-- not subject to this test, and we cannot extract the
-- component type in such cases since it is not present.
elsif Comes_From_Source (A)
and then Ada_Version >= Ada_2005
then
declare
Comp_Type : constant Entity_Id :=
Component_Type
(Etype (Expression (A)));
begin
if (Is_Private_Type (Comp_Type)
and then not Is_Generic_Type (Comp_Type))
or else Is_Tagged_Type (Comp_Type)
or else Is_Volatile (Comp_Type)
then
Error_Msg_N
("component type of a view conversion cannot"
& " be private, tagged, or volatile"
& " (RM 4.6 (24))",
Expression (A));
end if;
end;
end if;
end if;
end if;
-- Resolve expression if conversion is all OK
if (Conversion_OK (A)
or else Valid_Conversion (A, Etype (A), Expression (A)))
and then not Is_Ref_To_Bit_Packed_Array (Expression (A))
then
Resolve (Expression (A));
end if;
-- If the actual is a function call that returns a limited
-- unconstrained object that needs finalization, create a
-- transient scope for it, so that it can receive the proper
-- finalization list.
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 (Is_Controlled (Etype (F)) or else Has_Task (Etype (F)))
then
Establish_Transient_Scope (A, Sec_Stack => 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.
-- This alleviates stack usage when several procedure calls in
-- the same statement list use concatenation. We do not perform
-- this wrapping for code statements, where the argument is a
-- static string, and we want to preserve warnings involving
-- sequences of such statements.
elsif Nkind (A) = N_Op_Concat
and then Nkind (N) = N_Procedure_Call_Statement
and then Expander_Active
and then
not (Is_Intrinsic_Subprogram (Nam)
and then Chars (Nam) = Name_Asm)
and then not Static_Concatenation (A)
then
Establish_Transient_Scope (A, Sec_Stack => False);
Resolve (A, Etype (F));
else
if Nkind (A) = N_Type_Conversion
and then Is_Array_Type (Etype (F))
and then not Same_Ancestor (Etype (F), Etype (Expression (A)))
and then
(Is_Limited_Type (Etype (F))
or else Is_Limited_Type (Etype (Expression (A))))
then
Error_Msg_N
("conversion between unrelated limited array types "
& "not allowed ('A'I-00246)", A);
if Is_Limited_Type (Etype (F)) then
Explain_Limited_Type (Etype (F), A);
end if;
if Is_Limited_Type (Etype (Expression (A))) then
Explain_Limited_Type (Etype (Expression (A)), A);
end if;
end if;
-- (Ada 2005: AI-251): If the actual is an allocator whose
-- directly designated type is a class-wide interface, we build
-- an anonymous access type to use it as the type of the
-- allocator. Later, when the subprogram call is expanded, if
-- the interface has a secondary dispatch table the expander
-- will add a type conversion to force the correct displacement
-- of the pointer.
if Nkind (A) = N_Allocator then
declare
DDT : constant Entity_Id :=
Directly_Designated_Type (Base_Type (Etype (F)));
New_Itype : Entity_Id;
begin
if Is_Class_Wide_Type (DDT)
and then Is_Interface (DDT)
then
New_Itype := Create_Itype (E_Anonymous_Access_Type, A);
Set_Etype (New_Itype, Etype (A));
Set_Directly_Designated_Type
(New_Itype, Directly_Designated_Type (Etype (A)));
Set_Etype (A, New_Itype);
end if;
-- Ada 2005, AI-162:If the actual is an allocator, the
-- innermost enclosing statement is the master of the
-- created object. This needs to be done with expansion
-- enabled only, otherwise the transient scope will not
-- be removed in the expansion of the wrapped construct.
if (Is_Controlled (DDT) or else Has_Task (DDT))
and then Expander_Active
then
Establish_Transient_Scope (A, Sec_Stack => False);
end if;
end;
if Ekind (Etype (F)) = E_Anonymous_Access_Type then
Check_Restriction (No_Access_Parameter_Allocators, A);
end if;
end if;
-- (Ada 2005): The call may be to a primitive operation of a
-- tagged synchronized type, declared outside of the type. In
-- this case the controlling actual must be converted to its
-- corresponding record type, which is the formal type. The
-- actual may be a subtype, either because of a constraint or
-- because it is a generic actual, so use base type to locate
-- concurrent type.
F_Typ := Base_Type (Etype (F));
if Is_Tagged_Type (F_Typ)
and then (Is_Concurrent_Type (F_Typ)
or else Is_Concurrent_Record_Type (F_Typ))
then
-- If the actual is overloaded, look for an interpretation
-- that has a synchronized type.
if not Is_Overloaded (A) then
A_Typ := Base_Type (Etype (A));
else
declare
Index : Interp_Index;
It : Interp;
begin
Get_First_Interp (A, Index, It);
while Present (It.Typ) loop
if Is_Concurrent_Type (It.Typ)
or else Is_Concurrent_Record_Type (It.Typ)
then
A_Typ := Base_Type (It.Typ);
exit;
end if;
Get_Next_Interp (Index, It);
end loop;
end;
end if;
declare
Full_A_Typ : Entity_Id;
begin
if Present (Full_View (A_Typ)) then
Full_A_Typ := Base_Type (Full_View (A_Typ));
else
Full_A_Typ := A_Typ;
end if;
-- Tagged synchronized type (case 1): the actual is a
-- concurrent type.
if Is_Concurrent_Type (A_Typ)
and then Corresponding_Record_Type (A_Typ) = F_Typ
then
Rewrite (A,
Unchecked_Convert_To
(Corresponding_Record_Type (A_Typ), A));
Resolve (A, Etype (F));
-- Tagged synchronized type (case 2): the formal is a
-- concurrent type.
elsif Ekind (Full_A_Typ) = E_Record_Type
and then Present
(Corresponding_Concurrent_Type (Full_A_Typ))
and then Is_Concurrent_Type (F_Typ)
and then Present (Corresponding_Record_Type (F_Typ))
and then Full_A_Typ = Corresponding_Record_Type (F_Typ)
then
Resolve (A, Corresponding_Record_Type (F_Typ));
-- Common case
else
Resolve (A, Etype (F));
end if;
end;
-- Not a synchronized operation
else
Resolve (A, Etype (F));
end if;
end if;
A_Typ := Etype (A);
F_Typ := Etype (F);
-- An actual cannot be an untagged formal incomplete type
if Ekind (A_Typ) = E_Incomplete_Type
and then not Is_Tagged_Type (A_Typ)
and then Is_Generic_Type (A_Typ)
then
Error_Msg_N
("invalid use of untagged formal incomplete type", A);
end if;
if Comes_From_Source (Original_Node (N))
and then Nkind_In (Original_Node (N), N_Function_Call,
N_Procedure_Call_Statement)
then
-- In formal mode, check that actual parameters matching
-- formals of tagged types are objects (or ancestor type
-- conversions of objects), not general expressions.
if Is_Actual_Tagged_Parameter (A) then
if Is_SPARK_05_Object_Reference (A) then
null;
elsif Nkind (A) = N_Type_Conversion then
declare
Operand : constant Node_Id := Expression (A);
Operand_Typ : constant Entity_Id := Etype (Operand);
Target_Typ : constant Entity_Id := A_Typ;
begin
if not Is_SPARK_05_Object_Reference (Operand) then
Check_SPARK_05_Restriction
("object required", Operand);
-- In formal mode, the only view conversions are those
-- involving ancestor conversion of an extended type.
elsif not
(Is_Tagged_Type (Target_Typ)
and then not Is_Class_Wide_Type (Target_Typ)
and then Is_Tagged_Type (Operand_Typ)
and then not Is_Class_Wide_Type (Operand_Typ)
and then Is_Ancestor (Target_Typ, Operand_Typ))
then
if Ekind_In
(F, E_Out_Parameter, E_In_Out_Parameter)
then
Check_SPARK_05_Restriction
("ancestor conversion is the only permitted "
& "view conversion", A);
else
Check_SPARK_05_Restriction
("ancestor conversion required", A);
end if;
else
null;
end if;
end;
else
Check_SPARK_05_Restriction ("object required", A);
end if;
-- In formal mode, the only view conversions are those
-- involving ancestor conversion of an extended type.
elsif Nkind (A) = N_Type_Conversion
and then Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter)
then
Check_SPARK_05_Restriction
("ancestor conversion is the only permitted view "
& "conversion", A);
end if;
end if;
-- has warnings suppressed, then we reset Never_Set_In_Source for
-- the calling entity. The reason for this is to catch cases like
-- GNAT.Spitbol.Patterns.Vstring_Var where the called subprogram
-- uses trickery to modify an IN parameter.
if Ekind (F) = E_In_Parameter
and then Is_Entity_Name (A)
and then Present (Entity (A))
and then Ekind (Entity (A)) = E_Variable
and then Has_Warnings_Off (F_Typ)
then
Set_Never_Set_In_Source (Entity (A), False);
end if;
-- Perform error checks for IN and IN OUT parameters
if Ekind (F) /= E_Out_Parameter then
-- Check unset reference. For scalar parameters, it is clearly
-- wrong to pass an uninitialized value as either an IN or
-- IN-OUT parameter. For composites, it is also clearly an
-- error to pass a completely uninitialized value as an IN
-- parameter, but the case of IN OUT is trickier. We prefer
-- not to give a warning here. For example, suppose there is
-- a routine that sets some component of a record to False.
-- It is perfectly reasonable to make this IN-OUT and allow
-- either initialized or uninitialized records to be passed
-- in this case.
-- For partially initialized composite values, we also avoid
-- warnings, since it is quite likely that we are passing a
-- partially initialized value and only the initialized fields
-- will in fact be read in the subprogram.
if Is_Scalar_Type (A_Typ)
or else (Ekind (F) = E_In_Parameter
and then not Is_Partially_Initialized_Type (A_Typ))
then
Check_Unset_Reference (A);
end if;
-- In Ada 83 we cannot pass an OUT parameter as an IN or IN OUT
-- actual to a nested call, since this constitutes a reading of
-- the parameter, which is not allowed.
if Is_Entity_Name (A)
and then Ekind (Entity (A)) = E_Out_Parameter
then
if Ada_Version = Ada_83 then
Error_Msg_N
("(Ada 83) illegal reading of out parameter", A);
-- An effectively volatile OUT parameter cannot act as IN or
-- IN OUT actual in a call (SPARK RM 7.1.3(11)).
elsif SPARK_Mode = On
and then Is_Effectively_Volatile (Entity (A))
then
Error_Msg_N
("illegal reading of volatile OUT parameter", A);
end if;
end if;
end if;
-- Case of OUT or IN OUT parameter
if Ekind (F) /= E_In_Parameter then
-- For an Out parameter, check for useless assignment. Note
-- that we can't set Last_Assignment this early, because we may
-- kill current values in Resolve_Call, and that call would
-- clobber the Last_Assignment field.
-- Note: call Warn_On_Useless_Assignment before doing the check
-- below for Is_OK_Variable_For_Out_Formal so that the setting
-- of Referenced_As_LHS/Referenced_As_Out_Formal properly
-- reflects the last assignment, not this one.
if Ekind (F) = E_Out_Parameter then
if Warn_On_Modified_As_Out_Parameter (F)
and then Is_Entity_Name (A)
and then Present (Entity (A))
and then Comes_From_Source (N)
then
Warn_On_Useless_Assignment (Entity (A), A);
end if;
end if;
-- Validate the form of the actual. Note that the call to
-- Is_OK_Variable_For_Out_Formal generates the required
-- reference in this case.
-- 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);
if Is_Subprogram (Current_Scope)
and then
(Is_Invariant_Procedure (Current_Scope)
or else Is_Predicate_Function (Current_Scope))
then
Error_Msg_N
("function used in predicate cannot "
& "modify its argument", F);
end if;
end if;
-- What's the following about???
if Is_Entity_Name (A) then
Kill_Checks (Entity (A));
else
Kill_All_Checks;
end if;
end if;
if Etype (A) = Any_Type then
Set_Etype (N, Any_Type);
return;
end if;
-- Apply appropriate constraint/predicate checks for IN [OUT] case
if Ekind_In (F, E_In_Parameter, E_In_Out_Parameter) then
-- Apply predicate tests except in certain special cases. Note
-- that it might be more consistent to apply these only when
-- expansion is active (in Exp_Ch6.Expand_Actuals), as we do
-- for the outbound predicate tests ???
if Predicate_Tests_On_Arguments (Nam) then
Apply_Predicate_Check (A, F_Typ);
end if;
-- Apply required constraint checks
-- Gigi looks at the check flag and uses the appropriate types.
-- For now since one flag is used there is an optimization
-- which might not be done in the IN OUT case since Gigi does
-- not do any analysis. More thought required about this ???
-- In fact is this comment obsolete??? doesn't the expander now
-- generate all these tests anyway???
if Is_Scalar_Type (Etype (A)) then
Apply_Scalar_Range_Check (A, F_Typ);
elsif Is_Array_Type (Etype (A)) then
Apply_Length_Check (A, F_Typ);
elsif Is_Record_Type (F_Typ)
and then Has_Discriminants (F_Typ)
and then Is_Constrained (F_Typ)
and then (not Is_Derived_Type (F_Typ)
or else Comes_From_Source (Nam))
then
Apply_Discriminant_Check (A, F_Typ);
-- For view conversions of a discriminated object, apply
-- check to object itself, the conversion alreay has the
-- proper type.
if Nkind (A) = N_Type_Conversion
and then Is_Constrained (Etype (Expression (A)))
then
Apply_Discriminant_Check (Expression (A), F_Typ);
end if;
elsif Is_Access_Type (F_Typ)
and then Is_Array_Type (Designated_Type (F_Typ))
and then Is_Constrained (Designated_Type (F_Typ))
then
Apply_Length_Check (A, F_Typ);
elsif Is_Access_Type (F_Typ)
and then Has_Discriminants (Designated_Type (F_Typ))
and then Is_Constrained (Designated_Type (F_Typ))
then
Apply_Discriminant_Check (A, F_Typ);
else
Apply_Range_Check (A, F_Typ);
end if;
-- Ada 2005 (AI-231): Note that the controlling parameter case
-- already existed in Ada 95, which is partially checked
-- elsewhere (see Checks), and we don't want the warning
-- message to differ.
if Is_Access_Type (F_Typ)
and then Can_Never_Be_Null (F_Typ)
and then Known_Null (A)
then
if Is_Controlling_Formal (F) then
Apply_Compile_Time_Constraint_Error
(N => A,
Msg => "null value not allowed here??",
Reason => CE_Access_Check_Failed);
elsif Ada_Version >= Ada_2005 then
Apply_Compile_Time_Constraint_Error
(N => A,
Msg => "(Ada 2005) null not allowed in "
& "null-excluding formal??",
Reason => CE_Null_Not_Allowed);
end if;
end if;
end if;
-- Checks for OUT parameters and IN OUT parameters
if Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter) then
-- If there is a type conversion, to make sure the return value
-- meets the constraints of the variable before the conversion.
if Nkind (A) = N_Type_Conversion then
if Is_Scalar_Type (A_Typ) then
Apply_Scalar_Range_Check
(Expression (A), Etype (Expression (A)), A_Typ);
else
Apply_Range_Check
(Expression (A), Etype (Expression (A)), A_Typ);
end if;
-- If no conversion apply scalar range checks and length checks
-- base on the subtype of the actual (NOT that of the formal).
else
if Is_Scalar_Type (F_Typ) then