Google Git
Sign in
gnu / gcc / a8404c07e7fca388c02c39077865f7d5fa928430 / . / gcc / ada / sem_res.adb
blob: e702df68a324c773ce44b5debb00f211c1707c04 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S E M _ R E S --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2022, 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 Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
with Debug_A; use Debug_A;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Errout; use Errout;
with Expander; use Expander;
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7;
with Exp_Disp; use Exp_Disp;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
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_Aggr; use Sem_Aggr;
with Sem_Attr; use Sem_Attr;
with Sem_Aux; use Sem_Aux;
with Sem_Case; use Sem_Case;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch4; use Sem_Ch4;
with Sem_Ch5; use Sem_Ch5;
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_Elab; use Sem_Elab;
with Sem_Elim; use Sem_Elim;
with Sem_Eval; use Sem_Eval;
with Sem_Intr; use Sem_Intr;
with Sem_Mech; use Sem_Mech;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Sinfo.CN; use Sinfo.CN;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
with Strub; use Strub;
with Style; use Style;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
with Urealp; use Urealp;
with Warnsw; use Warnsw;
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
function Has_Applicable_User_Defined_Literal
(N : Node_Id;
Typ : Entity_Id) return Boolean;
-- If N is a literal or a named number, check whether Typ
-- has a user-defined literal aspect that can apply to N.
-- If present, replace N with a call to the corresponding
-- function and return True.
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 (Call : Node_Id) return Boolean;
-- Given a call node, Call, 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_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 denotes an atomic object that has an address
-- clause (the case in which we may want to issue a warning).
function Is_Definite_Access_Type (E : N_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 Preanalyze_And_Resolve
(N : Node_Id;
T : Entity_Id;
With_Freezing : Boolean);
-- Subsidiary of public versions of Preanalyze_And_Resolve.
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_Dependent_Expression
(N : Node_Id;
Expr : Node_Id;
Typ : Entity_Id);
-- Internal procedure to resolve the dependent expression Expr of the
-- conditional expression N with type Typ.
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_Declare_Expression (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_Target_Name (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_Implicit_Dereference (P : Node_Id);
-- Called when P is the prefix of an indexed component, or of a selected
-- component, or of a slice. If P is of an access type, we unconditionally
-- rewrite it as an explicit dereference. This ensures that the expander
-- and the code generator have a fully explicit tree to work with.
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. This rewrites the conversion into a simpler form.
function Try_User_Defined_Literal
(N : Node_Id;
Typ : Entity_Id) return Boolean;
-- If an operator node has a literal operand, check whether the type
-- of the context, or the type of the other operand has a user-defined
-- literal aspect that can be applied to the literal to resolve the node.
-- If such aspect exists, replace literal with a call to the
-- corresponding function and return True, return false otherwise.
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;
-------------------------------------
-- Has_Applicable_User_Defined_Literal --
-------------------------------------
function Has_Applicable_User_Defined_Literal
(N : Node_Id;
Typ : Entity_Id) return Boolean
is
Loc : constant Source_Ptr := Sloc (N);
Literal_Aspect_Map :
constant array (N_Numeric_Or_String_Literal) of Aspect_Id :=
(N_Integer_Literal => Aspect_Integer_Literal,
N_Real_Literal => Aspect_Real_Literal,
N_String_Literal => Aspect_String_Literal);
Named_Number_Aspect_Map : constant array (Named_Kind) of Aspect_Id :=
(E_Named_Integer => Aspect_Integer_Literal,
E_Named_Real => Aspect_Real_Literal);
Lit_Aspect : Aspect_Id;
Callee : Entity_Id;
Name : Node_Id;
Param1 : Node_Id;
Param2 : Node_Id;
Params : List_Id;
Call : Node_Id;
Expr : Node_Id;
begin
if (Nkind (N) in N_Numeric_Or_String_Literal
and then Present
(Find_Aspect (Typ, Literal_Aspect_Map (Nkind (N)))))
or else
(Nkind (N) = N_Identifier
and then Is_Named_Number (Entity (N))
and then
Present
(Find_Aspect
(Typ, Named_Number_Aspect_Map (Ekind (Entity (N))))))
then
Lit_Aspect :=
(if Nkind (N) = N_Identifier
then Named_Number_Aspect_Map (Ekind (Entity (N)))
else Literal_Aspect_Map (Nkind (N)));
Callee :=
Entity (Expression (Find_Aspect (Typ, Lit_Aspect)));
Name := Make_Identifier (Loc, Chars (Callee));
if Is_Derived_Type (Typ)
and then Is_Tagged_Type (Typ)
and then Base_Type (Etype (Callee)) /= Base_Type (Typ)
then
Callee :=
Corresponding_Primitive_Op
(Ancestor_Op => Callee,
Descendant_Type => Base_Type (Typ));
end if;
-- Handle an identifier that denotes a named number.
if Nkind (N) = N_Identifier then
Expr := Expression (Declaration_Node (Entity (N)));
if Ekind (Entity (N)) = E_Named_Integer then
UI_Image (Expr_Value (Expr), Decimal);
Start_String;
Store_String_Chars
(UI_Image_Buffer (1 .. UI_Image_Length));
Param1 := Make_String_Literal (Loc, End_String);
Params := New_List (Param1);
else
UI_Image (Norm_Num (Expr_Value_R (Expr)), Decimal);
Start_String;
if UR_Is_Negative (Expr_Value_R (Expr)) then
Store_String_Chars ("-");
end if;
Store_String_Chars
(UI_Image_Buffer (1 .. UI_Image_Length));
Param1 := Make_String_Literal (Loc, End_String);
-- Note: Set_Etype is called below on Param1
UI_Image (Norm_Den (Expr_Value_R (Expr)), Decimal);
Start_String;
Store_String_Chars
(UI_Image_Buffer (1 .. UI_Image_Length));
Param2 := Make_String_Literal (Loc, End_String);
Set_Etype (Param2, Standard_String);
Params := New_List (Param1, Param2);
if Present (Related_Expression (Callee)) then
Callee := Related_Expression (Callee);
else
Error_Msg_NE
("cannot resolve & for a named real", N, Callee);
return False;
end if;
end if;
elsif Nkind (N) = N_String_Literal then
Param1 := Make_String_Literal (Loc, Strval (N));
Params := New_List (Param1);
else
Param1 :=
Make_String_Literal
(Loc, String_From_Numeric_Literal (N));
Params := New_List (Param1);
end if;
Call :=
Make_Function_Call
(Sloc => Loc,
Name => Name,
Parameter_Associations => Params);
Set_Entity (Name, Callee);
Set_Is_Overloaded (Name, False);
if Lit_Aspect = Aspect_String_Literal then
Set_Etype (Param1, Standard_Wide_Wide_String);
else
Set_Etype (Param1, Standard_String);
end if;
Set_Etype (Call, Etype (Callee));
-- Conversion not needed if the result type of the call is class-wide
-- or if the result type matches the context type.
if not Is_Class_Wide_Type (Typ)
and then Base_Type (Etype (Call)) /= Base_Type (Typ)
then
-- Conversion may be needed in case of an inherited
-- aspect of a derived type. For a null extension, we
-- use a null extension aggregate instead because the
-- downward type conversion would be illegal.
if Is_Null_Extension_Of
(Descendant => Typ,
Ancestor => Etype (Call))
then
Call := Make_Extension_Aggregate (Loc,
Ancestor_Part => Call,
Null_Record_Present => True);
else
Call := Convert_To (Typ, Call);
end if;
end if;
Rewrite (N, Call);
Analyze_And_Resolve (N, Typ);
return True;
else
return False;
end if;
end Has_Applicable_User_Defined_Literal;
----------------------------
-- 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 (Parent (Parent (P))) in 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 (PN) in 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 Nkind (P) not in
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 (Parent (P)) in 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 Comes_From_Source (N)
and then not Is_Visible_Operator (Original_Node (N), T)
and then not Error_Posted (N)
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 (Call : Node_Id) return Boolean is
function Invoked_With_Different_Arguments (N : Node_Id) return Boolean;
-- Determine whether call N invokes the related enclosing subprogram
-- with actuals that differ from the subprogram's formals.
function Is_Conditional_Statement (N : Node_Id) return Boolean;
-- Determine whether arbitrary node N denotes a conditional construct
function Is_Control_Flow_Statement (N : Node_Id) return Boolean;
-- Determine whether arbitrary node N denotes a control flow statement
-- or a construct that may contains such a statement.
function Is_Immediately_Within_Body (N : Node_Id) return Boolean;
-- Determine whether arbitrary node N appears immediately within the
-- statements of an entry or subprogram body.
function Is_Raise_Idiom (N : Node_Id) return Boolean;
-- Determine whether arbitrary node N appears immediately within the
-- body of an entry or subprogram, and is preceded by a single raise
-- statement.
function Is_Raise_Statement (N : Node_Id) return Boolean;
-- Determine whether arbitrary node N denotes a raise statement
function Is_Sole_Statement (N : Node_Id) return Boolean;
-- Determine whether arbitrary node N is the sole source statement in
-- the body of the enclosing subprogram.
function Preceded_By_Control_Flow_Statement (N : Node_Id) return Boolean;
-- Determine whether arbitrary node N is preceded by a control flow
-- statement.
function Within_Conditional_Statement (N : Node_Id) return Boolean;
-- Determine whether arbitrary node N appears within a conditional
-- construct.
--------------------------------------
-- Invoked_With_Different_Arguments --
--------------------------------------
function Invoked_With_Different_Arguments (N : Node_Id) return Boolean is
Subp : constant Entity_Id := Entity (Name (N));
Actual : Node_Id;
Formal : Entity_Id;
begin
-- Determine whether the formals of the invoked subprogram are not
-- used as actuals in the call.
Actual := First_Actual (Call);
Formal := First_Formal (Subp);
while Present (Actual) and then Present (Formal) loop
-- The current actual does not match the current formal
if not (Is_Entity_Name (Actual)
and then Entity (Actual) = Formal)
then
return True;
end if;
Next_Actual (Actual);
Next_Formal (Formal);
end loop;
return False;
end Invoked_With_Different_Arguments;
------------------------------
-- Is_Conditional_Statement --
------------------------------
function Is_Conditional_Statement (N : Node_Id) return Boolean is
begin
return
Nkind (N) in N_And_Then
| N_Case_Expression
| N_Case_Statement
| N_If_Expression
| N_If_Statement
| N_Or_Else;
end Is_Conditional_Statement;
-------------------------------
-- Is_Control_Flow_Statement --
-------------------------------
function Is_Control_Flow_Statement (N : Node_Id) return Boolean is
begin
-- It is assumed that all statements may affect the control flow in
-- some way. A raise statement may be expanded into a non-statement
-- node.
return Is_Statement (N) or else Is_Raise_Statement (N);
end Is_Control_Flow_Statement;
--------------------------------
-- Is_Immediately_Within_Body --
--------------------------------
function Is_Immediately_Within_Body (N : Node_Id) return Boolean is
HSS : constant Node_Id := Parent (N);
begin
return
Nkind (HSS) = N_Handled_Sequence_Of_Statements
and then Nkind (Parent (HSS)) in N_Entry_Body | N_Subprogram_Body
and then Is_List_Member (N)
and then List_Containing (N) = Statements (HSS);
end Is_Immediately_Within_Body;
--------------------
-- Is_Raise_Idiom --
--------------------
function Is_Raise_Idiom (N : Node_Id) return Boolean is
Raise_Stmt : Node_Id;
Stmt : Node_Id;
begin
if Is_Immediately_Within_Body (N) then
-- Assume that no raise statement has been seen yet
Raise_Stmt := Empty;
-- Examine the statements preceding the input node, skipping
-- internally-generated constructs.
Stmt := Prev (N);
while Present (Stmt) loop
-- Multiple raise statements violate the idiom
if Is_Raise_Statement (Stmt) then
if Present (Raise_Stmt) then
return False;
end if;
Raise_Stmt := Stmt;
elsif Comes_From_Source (Stmt) then
exit;
end if;
Stmt := Prev (Stmt);
end loop;
-- At this point the node must be preceded by a raise statement,
-- and the raise statement has to be the sole statement within
-- the enclosing entry or subprogram body.
return
Present (Raise_Stmt) and then Is_Sole_Statement (Raise_Stmt);
end if;
return False;
end Is_Raise_Idiom;
------------------------
-- Is_Raise_Statement --
------------------------
function Is_Raise_Statement (N : Node_Id) return Boolean is
begin
-- A raise statement may be transfomed into a Raise_xxx_Error node
return
Nkind (N) = N_Raise_Statement
or else Nkind (N) in N_Raise_xxx_Error;
end Is_Raise_Statement;
-----------------------
-- Is_Sole_Statement --
-----------------------
function Is_Sole_Statement (N : Node_Id) return Boolean is
Stmt : Node_Id;
begin
-- The input node appears within the statements of an entry or
-- subprogram body. Examine the statements preceding the node.
if Is_Immediately_Within_Body (N) then
Stmt := Prev (N);
while Present (Stmt) loop
-- The statement is preceded by another statement or a source
-- construct. This indicates that the node does not appear by
-- itself.
if Is_Control_Flow_Statement (Stmt)
or else Comes_From_Source (Stmt)
then
return False;
end if;
Stmt := Prev (Stmt);
end loop;
return True;
end if;
-- The input node is within a construct nested inside the entry or
-- subprogram body.
return False;
end Is_Sole_Statement;
----------------------------------------
-- Preceded_By_Control_Flow_Statement --
----------------------------------------
function Preceded_By_Control_Flow_Statement
(N : Node_Id) return Boolean
is
Stmt : Node_Id;
begin
if Is_List_Member (N) then
Stmt := Prev (N);
-- Examine the statements preceding the input node
while Present (Stmt) loop
if Is_Control_Flow_Statement (Stmt) then
return True;
end if;
Stmt := Prev (Stmt);
end loop;
return False;
end if;
-- Assume that the node is part of some control flow statement
return True;
end Preceded_By_Control_Flow_Statement;
----------------------------------
-- Within_Conditional_Statement --
----------------------------------
function Within_Conditional_Statement (N : Node_Id) return Boolean is
Stmt : Node_Id;
begin
Stmt := Parent (N);
while Present (Stmt) loop
if Is_Conditional_Statement (Stmt) then
return True;
-- Prevent the search from going too far
elsif Is_Body_Or_Package_Declaration (Stmt) then
exit;
end if;
Stmt := Parent (Stmt);
end loop;
return False;
end Within_Conditional_Statement;
-- Local variables
Call_Context : constant Node_Id :=
Enclosing_Declaration_Or_Statement (Call);
-- Start of processing for Check_Infinite_Recursion
begin
-- The call is assumed to be safe when the enclosing subprogram is
-- invoked with actuals other than its formals.
--
-- procedure Proc (F1 : ...; F2 : ...; ...; FN : ...) is
-- begin
-- ...
-- Proc (A1, A2, ..., AN);
-- ...
-- end Proc;
if Invoked_With_Different_Arguments (Call) then
return False;
-- The call is assumed to be safe when the invocation of the enclosing
-- subprogram depends on a conditional statement.
--
-- procedure Proc (F1 : ...; F2 : ...; ...; FN : ...) is
-- begin
-- ...
-- if Some_Condition then
-- Proc (F1, F2, ..., FN);
-- end if;
-- ...
-- end Proc;
elsif Within_Conditional_Statement (Call) then
return False;
-- The context of the call is assumed to be safe when the invocation of
-- the enclosing subprogram is preceded by some control flow statement.
--
-- procedure Proc (F1 : ...; F2 : ...; ...; FN : ...) is
-- begin
-- ...
-- if Some_Condition then
-- ...
-- end if;
-- ...
-- Proc (F1, F2, ..., FN);
-- ...
-- end Proc;
elsif Preceded_By_Control_Flow_Statement (Call_Context) then
return False;
-- Detect an idiom where the context of the call is preceded by a single
-- raise statement.
--
-- procedure Proc (F1 : ...; F2 : ...; ...; FN : ...) is
-- begin
-- raise ...;
-- Proc (F1, F2, ..., FN);
-- end Proc;
elsif Is_Raise_Idiom (Call_Context) then
return False;
end if;
-- At this point it is certain that infinite recursion will take place
-- as long as the call is executed. Detect a case where the context of
-- the call is the sole source statement within the subprogram body.
--
-- procedure Proc (F1 : ...; F2 : ...; ...; FN : ...) is
-- begin
-- Proc (F1, F2, ..., FN);
-- end Proc;
--
-- Install an explicit raise to prevent the infinite recursion.
if Is_Sole_Statement (Call_Context) then
Error_Msg_Warn := SPARK_Mode /= On;
Error_Msg_N ("!infinite recursion<<", Call);
Error_Msg_N ("\!Storage_Error [<<", Call);
Insert_Action (Call,
Make_Raise_Storage_Error (Sloc (Call),
Reason => SE_Infinite_Recursion));
-- Otherwise infinite recursion could take place, considering other flow
-- control constructs such as gotos, exit statements, etc.
else
Error_Msg_Warn := SPARK_Mode /= On;
Error_Msg_N ("!possible infinite recursion<<", Call);
Error_Msg_N ("\!??Storage_Error ]<<", Call);
end if;
return True;
end Check_Infinite_Recursion;
---------------------------------------
-- 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 Attribute_Name (Parent (N))
in 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 not Is_Valid_Name (Chars (N))
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 (Parent (N)) in 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 (Entity (Selector_Name (N))) in
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
Set_Etype (N, Empty);
Set_Entity (N, Empty);
Set_Is_Overloaded (N, False);
Change_Operator_Symbol_To_String_Literal (N);
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 : N_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 := Empty;
Orig_Type : Entity_Id := Empty;
Pack : Entity_Id;
type Kind_Test is access function (E : N_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));
-- Preserve the Comes_From_Source flag 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).
Preserve_Comes_From_Source (Op_Node, N);
-- Ensure that the corresponding operator has the same parent as the
-- original call. This guarantees that parent traversals performed by
-- the ABE mechanism succeed.
Set_Parent (Op_Node, Parent (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 Op_Name in Name_Op_Multiply | Name_Op_Divide
and then Is_Fixed_Point_Type (Etype (Act1))
and then Is_Fixed_Point_Type (Etype (Act2))
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 Op_Name in Name_Op_Eq | Name_Op_Ne
and then (Is_Anonymous_Access_Type (Etype (Act1))
or else Is_Anonymous_Access_Type (Etype (Act2)))
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 = Universal_Access then
Orig_Type := Type_In_P (Is_Definite_Access_Type'Access);
elsif Opnd_Type = Any_String then
Orig_Type := Type_In_P (Is_String_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 Op_Name in 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 Present (Opnd_Type)
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 Op_Name in 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, ' ');
Rewrite (N, Op_Node);
-- 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_Divide
| N_Op_Expon
| N_Op_Mod
| N_Op_Multiply
| N_Op_Rem
| N_Op_Subtract
=>
Resolve_Intrinsic_Operator (N, Typ);
when N_Op_Abs
| N_Op_Minus
| N_Op_Plus
=>
Resolve_Intrinsic_Unary_Operator (N, Typ);
when others =>
Resolve (N, Typ);
end case;
else
Resolve (N, Typ);
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;
With_Freezing : Boolean)
is
Save_Full_Analysis : constant Boolean := Full_Analysis;
Save_Must_Not_Freeze : constant Boolean := Must_Not_Freeze (N);
Save_Preanalysis_Count : constant Nat :=
Inside_Preanalysis_Without_Freezing;
begin
pragma Assert (Nkind (N) in N_Subexpr);
if not With_Freezing then
Set_Must_Not_Freeze (N);
Inside_Preanalysis_Without_Freezing :=
Inside_Preanalysis_Without_Freezing + 1;
end if;
Full_Analysis := False;
Expander_Mode_Save_And_Set (False);
-- See also Preanalyze_And_Resolve in sem.adb for similar handling
-- 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 GNATprove mode, most expansion is suppressed, and this
-- later reanalysis and reexpansion may not occur. GNATprove mode does
-- require the setting of checking flags for proof purposes, so we
-- do the GNATprove 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.
-- We also do not want to suppress checks if we are not dealing
-- with a default expression. One such case that is known to reach
-- this point is the expression of an expression function.
if GNATprove_Mode or Nkind (Parent (N)) = N_Simple_Return_Statement 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;
if not With_Freezing then
Set_Must_Not_Freeze (N, Save_Must_Not_Freeze);
Inside_Preanalysis_Without_Freezing :=
Inside_Preanalysis_Without_Freezing - 1;
end if;
pragma Assert
(Inside_Preanalysis_Without_Freezing = Save_Preanalysis_Count);
end Preanalyze_And_Resolve;
----------------------------
-- Preanalyze_And_Resolve --
----------------------------
procedure Preanalyze_And_Resolve (N : Node_Id; T : Entity_Id) is
begin
Preanalyze_And_Resolve (N, T, With_Freezing => False);
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;
------------------------------------------
-- Preanalyze_With_Freezing_And_Resolve --
------------------------------------------
procedure Preanalyze_With_Freezing_And_Resolve
(N : Node_Id;
T : Entity_Id)
is
begin
Preanalyze_And_Resolve (N, T, With_Freezing => True);
end Preanalyze_With_Freezing_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 Expander_Active then
null;
-- Allow the replacement of concurrent discriminants in GNATprove even
-- though this is a light expansion activity. Note that generic units
-- are not modified.
elsif GNATprove_Mode and not Inside_A_Generic then
null;
else
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 Present (Tsk) then
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 In_Predefined_Unit (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 (Get_Char_Code ('A'));
Rewrite (N,
Make_Character_Literal (Sloc (N),
Chars => Name_Find,
Char_Literal_Value =>
UI_From_CC (Get_Char_Code ('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));
-- Examine possible interpretations, and adapt the message
-- for inherited subprograms declared by a type derivation.
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;
-- Additional message and hint if the ambiguity involves an Ada 2022
-- container aggregate.
Check_Ambiguous_Aggregate (N);
end Report_Ambiguous_Argument;
-----------------------
-- Resolution_Failed --
-----------------------
procedure Resolution_Failed is
begin
Patch_Up_Value (N, Typ);
-- Set the type to the desired one to minimize cascaded errors. Note
-- that this is an approximation and does not work in all cases.
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 Attribute_Name (N) in 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;
-- 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, but if the node comes from source it is a
-- Declare_Expression and requires scope management.
if Nkind (N) = N_Expression_With_Actions then
if Comes_From_Source (N) and then not Is_Rewrite_Substitution (N) then
Resolve_Declare_Expression (N, Typ);
else
Resolve (Expression (N), Typ);
end if;
Found := True;
Expr_Type := Etype (Expression (N));
-- The resolution of a conditional expression that is the operand of a
-- type conversion is determined by the conversion (RM 4.5.7(10/3)).
elsif Nkind (N) in N_Case_Expression | N_If_Expression
and then Nkind (Parent (N)) = N_Type_Conversion
then
Found := True;
Expr_Type := Etype (Parent (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
From_Lib := Comes_From_Predefined_Lib_Unit (N);
-- 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 not Is_Universal_Numeric_Type (Typ)
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. This can also happen for
-- a generalized indexing operation.
if Nkind (N) in N_Subprogram_Call
or else (Nkind (N) = N_Indexed_Component
and then Present (Generalized_Indexing (N)))
then
declare
A : Node_Id;
E : Node_Id;
begin
if Nkind (N) = N_Indexed_Component then
Rewrite (N, Generalized_Indexing (N));
end if;
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) in N_Case_Expression
| N_Character_Literal
| N_Delta_Aggregate
| N_If_Expression
then
Set_Etype (N, Expr_Type);
-- AI05-0139-2: Expression is overloaded because type has
-- implicit dereference. The context may be the one that
-- requires implicit dereferemce.
elsif Has_Implicit_Dereference (Expr_Type) then
Set_Etype (N, Expr_Type);
Set_Is_Overloaded (N, False);
-- If the expression is an entity, generate a reference
-- to it, as this is not done for an overloaded construct
-- during analysis.
if Is_Entity_Name (N)
and then Comes_From_Source (N)
then
Generate_Reference (Entity (N), N);
-- Examine access discriminants of entity type,
-- to check whether one of them yields the
-- expected type.
declare
Disc : Entity_Id :=
First_Discriminant (Etype (Entity (N)));
begin
while Present (Disc) loop
exit when Is_Access_Type (Etype (Disc))
and then Has_Implicit_Dereference (Disc)
and then Designated_Type (Etype (Disc)) = Typ;
Next_Discriminant (Disc);
end loop;
if Present (Disc) then
Build_Explicit_Dereference (N, Disc);
end if;
end;
end if;
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 (N) in N_Attribute_Reference
| N_And_Then
| N_Explicit_Dereference
| N_Identifier
| 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 call to function & as a statement",
Name (N), Entity (Name (N)));
Error_Msg_N
("\return value of a function call cannot be ignored",
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
if Ada_Version >= Ada_2022
and then Has_Aspect (Typ, Aspect_Aggregate)
then
Resolve_Container_Aggregate (N, Typ);
if Expander_Active then
Expand (N);
end if;
return;
end if;
-- 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 Nkind (Elmt) /= N_Iterated_Component_Association
and then 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;
-- If node is a literal and context type has a user-defined
-- literal aspect, rewrite node as a call to the corresponding
-- function, which plays the role of an implicit conversion.
if Nkind (N) in
N_Numeric_Or_String_Literal | N_Identifier
and then Has_Applicable_User_Defined_Literal (N, Typ)
then
Analyze_And_Resolve (N, Typ);
return;
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;
-- Under relaxed RM semantics silently replace occurrences of null
-- by System.Null_Address.
elsif Null_To_Null_Address_Convert_OK (N, Typ) then
Replace_Null_By_Null_Address (N);
Analyze_And_Resolve (N, Typ);
return;
end if;
-- That special Allow_Integer_Address check did not apply, 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;
-- Recognize the case of a quantified expression being mistaken
-- for an iterated component association because the user
-- forgot the "all" or "some" keyword after "for". Because the
-- error message starts with "missing ALL", we automatically
-- benefit from the associated CODEFIX, which requires that
-- the message is located on the identifier following "for"
-- in order for the CODEFIX to insert "all" in the right place.
elsif Nkind (N) = N_Aggregate
and then List_Length (Component_Associations (N)) = 1
and then Nkind (First (Component_Associations (N)))
= N_Iterated_Component_Association
and then Is_Boolean_Type (Typ)
then
if Present
(Iterator_Specification
(First (Component_Associations (N))))
then
Error_Msg_N -- CODEFIX
("missing ALL or SOME in quantified expression",
Defining_Identifier
(Iterator_Specification
(First (Component_Associations (N)))));
else
Error_Msg_N -- CODEFIX
("missing ALL or SOME in quantified expression",
Defining_Identifier
(First (Component_Associations (N))));
end if;
-- For an operator with no interpretation, check whether
-- one of its operands may be a user-defined literal.
elsif Nkind (N) in N_Op
and then Try_User_Defined_Literal (N, Typ)
then
return;
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 interpretation
else
-- Prevent implicit conversions between access-to-subprogram types
-- with different strub modes. Explicit conversions are acceptable in
-- some circumstances. We don't have to be concerned about data or
-- access-to-data types. Conversions between data types can safely
-- drop or add strub attributes from types, because strub effects are
-- associated with the locations rather than values. E.g., converting
-- a hypothetical Strub_Integer variable to Integer would load the
-- value from the variable, enabling stack scrabbing for the
-- enclosing subprogram, and then convert the value to Integer. As
-- for conversions between access-to-data types, that's no different
-- from any other case of type punning.
if Is_Access_Type (Typ)
and then Ekind (Designated_Type (Typ)) = E_Subprogram_Type
and then Is_Access_Type (Expr_Type)
and then Ekind (Designated_Type (Expr_Type)) = E_Subprogram_Type
then
Check_Same_Strub_Mode
(Designated_Type (Typ), Designated_Type (Expr_Type));
end if;
-- 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
Nondispatching_Call_To_Abstract_Operation
(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_Delta_Aggregate =>
Resolve_Delta_Aggregate (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_Ge
| N_Op_Gt
| N_Op_Le
| N_Op_Lt
=>
Resolve_Comparison_Op (N, Ctx_Type);
when N_Op_Not =>
Resolve_Op_Not (N, Ctx_Type);
when N_Op_Add
| N_Op_Divide
| N_Op_Mod
| N_Op_Multiply
| N_Op_Rem
| N_Op_Subtract
=>
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_Abs
| N_Op_Minus
| N_Op_Plus
=>
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_Target_Name =>
Resolve_Target_Name (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;
-- Mark relevant use-type and use-package clauses as effective using
-- the original node because constant folding may have occurred and
-- removed references that need to be examined.
if Nkind (Original_Node (N)) in N_Op then
Mark_Use_Clauses (Original_Node (N));
end if;
-- 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 (Base_Type (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.
-- As elsewhere we do not emit freeze node within a generic.
if not Inside_A_Generic then
Freeze_Expression (N);
end if;
-- 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_Typ : Entity_Id := Empty; -- init to avoid warning
F : Entity_Id;
F_Typ : Entity_Id;
Prev : Node_Id := Empty;
Orig_A : Node_Id;
Real_F : Entity_Id := Empty; -- init to avoid warning
Real_Subp : Entity_Id;
-- If the subprogram being called is an inherited operation for
-- a formal derived type in an instance, Real_Subp is the subprogram
-- that will be called. It may have different formal names than the
-- operation of the formal in the generic, so after actual is resolved
-- the name of the actual in a named association must carry the name
-- of the actual of the subprogram being called.
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 Flag_Effectively_Volatile_Objects (Expr : Node_Id);
-- Emit an error concerning the illegal usage of an effectively volatile
-- object for reading in interfering context (SPARK RM 7.1.3(10)).
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.
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 Object_Type_Has_Constrained_Partial_View
(Typ => F_Typ, Scop => Current_Scope)
then
null;
else
Error_Msg_NE ("untagged actual does not statically 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)))
< Static_Accessibility_Level (A, Object_Decl_Level)
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))))
< Static_Accessibility_Level (A, Object_Decl_Level)
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 is to an
-- operator symbol (which is usually in infix form), 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 (Nkind (Name (N)) = N_Identifier
and then Present (Entity (Name (N)))
and then Nkind (Entity (Name (N))) =
N_Defining_Operator_Symbol)
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;
---------------------------------------
-- Flag_Effectively_Volatile_Objects --
---------------------------------------
procedure Flag_Effectively_Volatile_Objects (Expr : Node_Id) is
function Flag_Object (N : Node_Id) return Traverse_Result;
-- Determine whether arbitrary node N denotes an effectively volatile
-- object for reading and if it does, emit an error.
-----------------
-- Flag_Object --
-----------------
function Flag_Object (N : Node_Id) return Traverse_Result is
Id : Entity_Id;
begin
case Nkind (N) is
-- Do not consider nested function calls because they have
-- already been processed during their own resolution.
when N_Function_Call =>
return Skip;
when N_Identifier | N_Expanded_Name =>
Id := Entity (N);
-- Identifiers of components and discriminants are not names
-- in the sense of Ada RM 4.1. They can only occur as a
-- selector_name in selected_component or as a choice in
-- component_association.
if Present (Id)
and then Is_Object (Id)
and then Ekind (Id) not in E_Component | E_Discriminant
and then Is_Effectively_Volatile_For_Reading (Id)
and then
not Is_OK_Volatile_Context (Context => Parent (N),
Obj_Ref => N,
Check_Actuals => True)
then
Error_Msg_N
("volatile object cannot appear in this context"
& " (SPARK RM 7.1.3(10))", N);
end if;
return Skip;
when others =>
return OK;
end case;
end Flag_Object;
procedure Flag_Objects is new Traverse_Proc (Flag_Object);
-- Start of processing for Flag_Effectively_Volatile_Objects
begin
Flag_Objects (Expr);
end Flag_Effectively_Volatile_Objects;
--------------------
-- 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);
-- Propagate dimension information, if any.
Copy_Dimensions (Default_Value (F), Actval);
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;
-------------------
-- 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;
if Is_Overloadable (Nam)
and then Is_Inherited_Operation (Nam)
and then In_Instance
and then Present (Alias (Nam))
and then Present (Overridden_Operation (Alias (Nam)))
then
Real_Subp := Alias (Nam);
else
Real_Subp := Empty;
end if;
if Present (First_Actual (N)) then
Check_Prefixed_Call;
end if;
A := First_Actual (N);
F := First_Formal (Nam);
if Present (Real_Subp) then
Real_F := First_Formal (Real_Subp);
end if;
while Present (F) loop
if No (A) and then Needs_No_Actuals (Nam) then
null;
-- If we have an error in any formal or actual, indicated by a type
-- of Any_Type, then abandon resolution attempt, and set result type
-- to Any_Type.
elsif Etype (F) = Any_Type then
Set_Etype (N, Any_Type);
return;
elsif Present (A) and then Etype (A) = Any_Type then
-- For the peculiar case of a user-defined comparison or equality
-- operator that does not return a boolean type, the operands may
-- have been ambiguous for the predefined operator and, therefore,
-- marked with Any_Type. Since the operation has been resolved to
-- the user-defined operator, that is irrelevant, so reset Etype.
if Nkind (Original_Node (N)) in N_Op_Compare
and then not Is_Boolean_Type (Etype (N))
then
Set_Etype (A, Etype (F));
-- Also skip this if the actual is a Raise_Expression, whose type
-- is imposed from context.
elsif Nkind (A) = N_Raise_Expression then
null;
else
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 (A)
then
-- Annotate the tree by creating a variable reference marker when
-- the actual denotes a variable reference, in case the reference
-- is folded or optimized away. The variable reference marker is
-- automatically saved for later examination by the ABE Processing
-- phase. The status of the reference is set as follows:
-- status mode
-- read IN, IN OUT
-- write IN OUT, OUT
if Needs_Variable_Reference_Marker
(N => A,
Calls_OK => True)
then
Build_Variable_Reference_Marker
(N => A,
Read => Ekind (F) /= E_Out_Parameter,
Write => Ekind (F) /= E_In_Parameter);
end if;
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_C