diff options
Diffstat (limited to 'gcc-4.4.3/gcc/ada/sem_res.adb')
| -rw-r--r-- | gcc-4.4.3/gcc/ada/sem_res.adb | 9688 |
1 files changed, 0 insertions, 9688 deletions
diff --git a/gcc-4.4.3/gcc/ada/sem_res.adb b/gcc-4.4.3/gcc/ada/sem_res.adb deleted file mode 100644 index 21369ae72..000000000 --- a/gcc-4.4.3/gcc/ada/sem_res.adb +++ /dev/null @@ -1,9688 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S E M _ R E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Atree; use Atree; -with Checks; use Checks; -with Debug; use Debug; -with Debug_A; use Debug_A; -with Einfo; use Einfo; -with Elists; use Elists; -with Errout; use Errout; -with Expander; use Expander; -with Exp_Disp; use Exp_Disp; -with Exp_Ch6; use Exp_Ch6; -with Exp_Ch7; use Exp_Ch7; -with Exp_Tss; use Exp_Tss; -with Exp_Util; use Exp_Util; -with Fname; use Fname; -with Freeze; use Freeze; -with 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 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_Cat; use Sem_Cat; -with Sem_Ch4; use Sem_Ch4; -with Sem_Ch6; use Sem_Ch6; -with Sem_Ch8; use Sem_Ch8; -with Sem_Ch13; use Sem_Ch13; -with Sem_Disp; use Sem_Disp; -with Sem_Dist; use Sem_Dist; -with Sem_Elab; use Sem_Elab; -with Sem_Eval; use Sem_Eval; -with Sem_Intr; use Sem_Intr; -with Sem_Util; use Sem_Util; -with Sem_Type; use Sem_Type; -with Sem_Warn; use Sem_Warn; -with Sinfo; use Sinfo; -with Snames; use Snames; -with Stand; use Stand; -with Stringt; use Stringt; -with Style; use Style; -with Targparm; use Targparm; -with Tbuild; use Tbuild; -with Uintp; use Uintp; -with Urealp; use Urealp; - -package body Sem_Res is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - -- Second pass (top-down) type checking and overload resolution procedures - -- Typ is the type required by context. These procedures propagate the - -- type information recursively to the descendants of N. If the node - -- is not overloaded, its Etype is established in the first pass. If - -- overloaded, the Resolve routines set the correct type. For arith. - -- operators, the Etype is the base type of the context. - - -- Note that Resolve_Attribute is separated off in Sem_Attr - - procedure Check_Discriminant_Use (N : Node_Id); - -- Enforce the restrictions on the use of discriminants when constraining - -- a component of a discriminated type (record or concurrent type). - - procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id); - -- Given a node for an operator associated with type T, check that - -- the operator is visible. Operators all of whose operands are - -- universal must be checked for visibility during resolution - -- because their type is not determinable based on their operands. - - procedure Check_Fully_Declared_Prefix - (Typ : Entity_Id; - Pref : Node_Id); - -- Check that the type of the prefix of a dereference is not incomplete - - function Check_Infinite_Recursion (N : Node_Id) return Boolean; - -- Given a call node, N, which is known to occur immediately within the - -- subprogram being called, determines whether it is a detectable case of - -- an infinite recursion, and if so, outputs appropriate messages. Returns - -- True if an infinite recursion is detected, and False otherwise. - - procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id); - -- If the type of the object being initialized uses the secondary stack - -- directly or indirectly, create a transient scope for the call to the - -- init proc. This is because we do not create transient scopes for the - -- initialization of individual components within the init proc itself. - -- Could be optimized away perhaps? - - function Is_Definite_Access_Type (E : Entity_Id) return Boolean; - -- Determine whether E is an access type declared by an access - -- declaration, and not an (anonymous) allocator type. - - function Is_Predefined_Op (Nam : Entity_Id) return Boolean; - -- Utility to check whether the name in the call is a predefined - -- operator, in which case the call is made into an operator node. - -- An instance of an intrinsic conversion operation may be given - -- an operator name, but is not treated like an operator. - - procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id); - -- If a default expression in entry call N depends on the discriminants - -- of the task, it must be replaced with a reference to the discriminant - -- of the task being called. - - procedure Resolve_Op_Concat_Arg - (N : Node_Id; - Arg : Node_Id; - Typ : Entity_Id; - Is_Comp : Boolean); - -- Internal procedure for Resolve_Op_Concat to resolve one operand of - -- concatenation operator. The operand is either of the array type or of - -- the component type. If the operand is an aggregate, and the component - -- type is composite, this is ambiguous if component type has aggregates. - - procedure Resolve_Op_Concat_First (N : Node_Id; Typ : Entity_Id); - -- Does the first part of the work of Resolve_Op_Concat - - procedure Resolve_Op_Concat_Rest (N : Node_Id; Typ : Entity_Id); - -- Does the "rest" of the work of Resolve_Op_Concat, after the left operand - -- has been resolved. See Resolve_Op_Concat for details. - - procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id); - procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id); - procedure Resolve_Call (N : Node_Id; Typ : Entity_Id); - procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id); - procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id); - procedure Resolve_Conditional_Expression (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_Entity_Name (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_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_Subprogram_Info (N : Node_Id; Typ : Entity_Id); - procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id); - procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id); - procedure Resolve_Unchecked_Expression (N : Node_Id; Typ : Entity_Id); - procedure Resolve_Unchecked_Type_Conversion (N : Node_Id; Typ : Entity_Id); - - function Operator_Kind - (Op_Name : Name_Id; - Is_Binary : Boolean) return Node_Kind; - -- Utility to map the name of an operator into the corresponding Node. Used - -- by other node rewriting procedures. - - procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id); - -- Resolve actuals of call, and add default expressions for missing ones. - -- N is the Node_Id for the subprogram call, and Nam is the entity of the - -- called subprogram. - - procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id); - -- Called from Resolve_Call, when the prefix denotes an entry or element - -- of entry family. Actuals are resolved as for subprograms, and the node - -- is rebuilt as an entry call. Also called for protected operations. Typ - -- is the context type, which is used when the operation is a protected - -- function with no arguments, and the return value is indexed. - - procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id); - -- A call to a user-defined intrinsic operator is rewritten as a call - -- to the corresponding predefined operator, with suitable conversions. - - procedure Resolve_Intrinsic_Unary_Operator (N : Node_Id; Typ : Entity_Id); - -- Ditto, for unary operators (only arithmetic ones) - - procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id); - -- If an operator node resolves to a call to a user-defined operator, - -- rewrite the node as a function call. - - procedure Make_Call_Into_Operator - (N : Node_Id; - Typ : Entity_Id; - Op_Id : Entity_Id); - -- Inverse transformation: if an operator is given in functional notation, - -- then after resolving the node, transform into an operator node, so - -- that operands are resolved properly. Recall that predefined operators - -- do not have a full signature and special resolution rules apply. - - procedure Rewrite_Renamed_Operator - (N : Node_Id; - Op : Entity_Id; - Typ : Entity_Id); - -- An operator can rename another, e.g. in an instantiation. In that - -- case, the proper operator node must be constructed and resolved. - - procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id); - -- The String_Literal_Subtype is built for all strings that are not - -- operands of a static concatenation operation. If the argument is - -- not a N_String_Literal node, then the call has no effect. - - procedure Set_Slice_Subtype (N : Node_Id); - -- Build subtype of array type, with the range specified by the slice - - procedure Simplify_Type_Conversion (N : Node_Id); - -- Called after N has been resolved and evaluated, but before range checks - -- have been applied. Currently simplifies a combination of floating-point - -- to integer conversion and Truncation attribute. - - function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id; - -- A universal_fixed expression in an universal context is unambiguous - -- if there is only one applicable fixed point type. Determining whether - -- there is only one requires a search over all visible entities, and - -- happens only in very pathological cases (see 6115-006). - - function Valid_Conversion - (N : Node_Id; - Target : Entity_Id; - Operand : Node_Id) return Boolean; - -- Verify legality rules given in 4.6 (8-23). Target is the target - -- type of the conversion, which may be an implicit conversion of - -- an actual parameter to an anonymous access type (in which case - -- N denotes the actual parameter and N = Operand). - - ------------------------- - -- Ambiguous_Character -- - ------------------------- - - 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_05 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; - - -- Version withs 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 - Svg : constant Suppress_Array := Scope_Suppress; - begin - Scope_Suppress := (others => True); - Analyze_And_Resolve (N, Typ); - Scope_Suppress := Svg; - end; - - else - declare - Svg : constant Boolean := Scope_Suppress (Suppress); - - begin - Scope_Suppress (Suppress) := True; - Analyze_And_Resolve (N, Typ); - Scope_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 - Svg : constant Suppress_Array := Scope_Suppress; - begin - Scope_Suppress := (others => True); - Analyze_And_Resolve (N); - Scope_Suppress := Svg; - end; - - else - declare - Svg : constant Boolean := Scope_Suppress (Suppress); - - begin - Scope_Suppress (Suppress) := True; - Analyze_And_Resolve (N); - Scope_Suppress (Suppress) := Svg; - end; - end if; - - if Current_Scope /= Scop - and then Scope_Is_Transient - then - Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress := - Scope_Suppress; - end if; - end Analyze_And_Resolve; - - ---------------------------- - -- Check_Discriminant_Use -- - ---------------------------- - - procedure Check_Discriminant_Use (N : Node_Id) is - PN : constant Node_Id := Parent (N); - Disc : constant Entity_Id := Entity (N); - P : Node_Id; - D : Node_Id; - - begin - -- Any use in a spec-expression is legal - - if In_Spec_Expression then - null; - - elsif Nkind (PN) = N_Range then - - -- Discriminant cannot be used to constrain a scalar type - - P := Parent (PN); - - if Nkind (P) = N_Range_Constraint - and then Nkind (Parent (P)) = N_Subtype_Indication - and then Nkind (Parent (Parent (P))) = N_Component_Definition - then - Error_Msg_N ("discriminant cannot constrain scalar type", N); - - elsif Nkind (P) = N_Index_Or_Discriminant_Constraint then - - -- The following check catches the unusual case where - -- a discriminant appears within an index constraint - -- that is part of a larger expression within a constraint - -- on a component, e.g. "C : Int range 1 .. F (new A(1 .. D))". - -- For now we only check case of record components, and - -- note that a similar check should also apply in the - -- case of discriminant constraints below. ??? - - -- Note that the check for N_Subtype_Declaration below is to - -- detect the valid use of discriminants in the constraints of a - -- subtype declaration when this subtype declaration appears - -- inside the scope of a record type (which is syntactically - -- illegal, but which may be created as part of derived type - -- processing for records). See Sem_Ch3.Build_Derived_Record_Type - -- for more info. - - if Ekind (Current_Scope) = E_Record_Type - and then Scope (Disc) = Current_Scope - and then not - (Nkind (Parent (P)) = N_Subtype_Indication - and then - Nkind_In (Parent (Parent (P)), N_Component_Definition, - N_Subtype_Declaration) - and then Paren_Count (N) = 0) - then - Error_Msg_N - ("discriminant must appear alone in component constraint", N); - return; - end if; - - -- Detect a common error: - - -- type R (D : Positive := 100) is record - -- Name : String (1 .. D); - -- end record; - - -- The default value causes an object of type R to be allocated - -- with room for Positive'Last characters. The RM does not mandate - -- the allocation of the maximum size, but that is what GNAT does - -- so we should warn the programmer that there is a problem. - - Check_Large : declare - SI : Node_Id; - T : Entity_Id; - TB : Node_Id; - CB : Entity_Id; - - function Large_Storage_Type (T : Entity_Id) return Boolean; - -- Return True if type T has a large enough range that - -- any array whose index type covered the whole range of - -- the type would likely raise Storage_Error. - - ------------------------ - -- Large_Storage_Type -- - ------------------------ - - function Large_Storage_Type (T : Entity_Id) return Boolean is - begin - -- The type is considered large if its bounds are known at - -- compile time and if it requires at least as many bits as - -- a Positive to store the possible values. - - return Compile_Time_Known_Value (Type_Low_Bound (T)) - and then Compile_Time_Known_Value (Type_High_Bound (T)) - and then - Minimum_Size (T, Biased => True) >= - RM_Size (Standard_Positive); - end Large_Storage_Type; - - -- Start of processing for Check_Large - - begin - -- Check that the Disc has a large range - - if not Large_Storage_Type (Etype (Disc)) then - goto No_Danger; - end if; - - -- If the enclosing type is limited, we allocate only the - -- default value, not the maximum, and there is no need for - -- a warning. - - if Is_Limited_Type (Scope (Disc)) then - goto No_Danger; - end if; - - -- Check that it is the high bound - - if N /= High_Bound (PN) - or else No (Discriminant_Default_Value (Disc)) - then - goto No_Danger; - end if; - - -- Check the array allows a large range at this bound. - -- First find the array - - SI := Parent (P); - - if Nkind (SI) /= N_Subtype_Indication then - goto No_Danger; - end if; - - T := Entity (Subtype_Mark (SI)); - - if not Is_Array_Type (T) then - goto No_Danger; - end if; - - -- Next, find the dimension - - TB := First_Index (T); - CB := First (Constraints (P)); - while True - and then Present (TB) - and then Present (CB) - and then CB /= PN - loop - Next_Index (TB); - Next (CB); - end loop; - - if CB /= PN then - goto No_Danger; - end if; - - -- Now, check the dimension has a large range - - if not Large_Storage_Type (Etype (TB)) then - goto No_Danger; - end if; - - -- Warn about the danger - - Error_Msg_N - ("?creation of & object may raise Storage_Error!", - Scope (Disc)); - - <<No_Danger>> - null; - - end Check_Large; - end if; - - -- Legal case is in index or discriminant constraint - - elsif Nkind_In (PN, N_Index_Or_Discriminant_Constraint, - N_Discriminant_Association) - then - if Paren_Count (N) > 0 then - Error_Msg_N - ("discriminant in constraint must appear alone", N); - - elsif Nkind (N) = N_Expanded_Name - and then Comes_From_Source (N) - then - Error_Msg_N - ("discriminant must appear alone as a direct name", N); - end if; - - return; - - -- Otherwise, context is an expression. It should not be within - -- (i.e. a subexpression of) a constraint for a component. - - else - D := PN; - P := Parent (PN); - while not Nkind_In (P, N_Component_Declaration, - N_Subtype_Indication, - N_Entry_Declaration) - loop - D := P; - P := Parent (P); - exit when No (P); - end loop; - - -- If the discriminant is used in an expression that is a bound - -- of a scalar type, an Itype is created and the bounds are attached - -- to its range, not to the original subtype indication. Such use - -- is of course a double fault. - - if (Nkind (P) = N_Subtype_Indication - and then Nkind_In (Parent (P), N_Component_Definition, - N_Derived_Type_Definition) - and then D = Constraint (P)) - - -- The constraint itself may be given by a subtype indication, - -- rather than by a more common discrete range. - - or else (Nkind (P) = N_Subtype_Indication - and then - Nkind (Parent (P)) = N_Index_Or_Discriminant_Constraint) - or else Nkind (P) = N_Entry_Declaration - or else Nkind (D) = N_Defining_Identifier - then - Error_Msg_N - ("discriminant in constraint must appear alone", N); - end if; - end if; - end Check_Discriminant_Use; - - -------------------------------- - -- Check_For_Visible_Operator -- - -------------------------------- - - procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id) is - begin - if Is_Invisible_Operator (N, T) then - Error_Msg_NE - ("operator for} is not directly visible!", N, First_Subtype (T)); - Error_Msg_N ("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_05 - and then Is_Entity_Name (Pref) - and then Ekind (Directly_Designated_Type (Etype (Pref))) = - E_Incomplete_Type - and then Is_Tagged_Type (Directly_Designated_Type (Etype (Pref))) - then - null; - else - Check_Fully_Declared (Typ, Parent (Pref)); - end if; - end Check_Fully_Declared_Prefix; - - ------------------------------ - -- Check_Infinite_Recursion -- - ------------------------------ - - function Check_Infinite_Recursion (N : Node_Id) return Boolean is - P : Node_Id; - C : Node_Id; - - function Same_Argument_List return Boolean; - -- Check whether list of actuals is identical to list of formals - -- of called function (which is also the enclosing scope). - - ------------------------ - -- Same_Argument_List -- - ------------------------ - - function Same_Argument_List return Boolean is - A : Node_Id; - F : Entity_Id; - Subp : Entity_Id; - - begin - if not Is_Entity_Name (Name (N)) then - return False; - else - Subp := Entity (Name (N)); - end if; - - F := First_Formal (Subp); - A := First_Actual (N); - while Present (F) and then Present (A) loop - if not Is_Entity_Name (A) - or else Entity (A) /= F - then - return False; - end if; - - Next_Actual (A); - Next_Formal (F); - end loop; - - return True; - end Same_Argument_List; - - -- Start of processing for Check_Infinite_Recursion - - begin - -- Special case, if this is a procedure call and is a call to the - -- current procedure with the same argument list, then this is for - -- sure an infinite recursion and we insert a call to raise SE. - - if Is_List_Member (N) - and then List_Length (List_Containing (N)) = 1 - and then Same_Argument_List - then - declare - P : constant Node_Id := Parent (N); - begin - if Nkind (P) = N_Handled_Sequence_Of_Statements - and then Nkind (Parent (P)) = N_Subprogram_Body - and then Is_Empty_List (Declarations (Parent (P))) - then - Error_Msg_N ("!?infinite recursion", N); - Error_Msg_N ("\!?Storage_Error will be raised at run time", N); - Insert_Action (N, - Make_Raise_Storage_Error (Sloc (N), - Reason => SE_Infinite_Recursion)); - return True; - end if; - end; - end if; - - -- If not that special case, search up tree, quitting if we reach a - -- construct (e.g. a conditional) that tells us that this is not a - -- case for an infinite recursion warning. - - C := N; - loop - P := Parent (C); - - -- If no parent, then we were not inside a subprogram, this can for - -- example happen when processing certain pragmas in a spec. Just - -- return False in this case. - - if No (P) then - return False; - end if; - - -- Done if we get to subprogram body, this is definitely an infinite - -- recursion case if we did not find anything to stop us. - - exit when Nkind (P) = N_Subprogram_Body; - - -- If appearing in conditional, result is false - - if Nkind_In (P, N_Or_Else, - N_And_Then, - N_If_Statement, - N_Case_Statement) - then - return False; - - elsif Nkind (P) = N_Handled_Sequence_Of_Statements - and then C /= First (Statements (P)) - then - -- If the call is the expression of a return statement and the - -- actuals are identical to the formals, it's worth a warning. - -- However, we skip this if there is an immediately preceding - -- raise statement, since the call is never executed. - - -- Furthermore, this corresponds to a common idiom: - - -- function F (L : Thing) return Boolean is - -- begin - -- raise Program_Error; - -- return F (L); - -- end F; - - -- for generating a stub function - - if Nkind (Parent (N)) = N_Simple_Return_Statement - and then Same_Argument_List - then - exit when not Is_List_Member (Parent (N)); - - -- OK, return statement is in a statement list, look for raise - - declare - Nod : Node_Id; - - begin - -- Skip past N_Freeze_Entity nodes generated by expansion - - Nod := Prev (Parent (N)); - while Present (Nod) - and then Nkind (Nod) = N_Freeze_Entity - loop - Prev (Nod); - end loop; - - -- If no raise statement, give warning - - exit when Nkind (Nod) /= N_Raise_Statement - and then - (Nkind (Nod) not in N_Raise_xxx_Error - or else Present (Condition (Nod))); - end; - end if; - - return False; - - else - C := P; - end if; - end loop; - - Error_Msg_N ("!?possible infinite recursion", N); - Error_Msg_N ("\!?Storage_Error may be raised at run time", N); - - return True; - end Check_Infinite_Recursion; - - ------------------------------- - -- Check_Initialization_Call -- - ------------------------------- - - procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id) is - Typ : constant Entity_Id := Etype (First_Formal (Nam)); - - function Uses_SS (T : Entity_Id) return Boolean; - -- Check whether the creation of an object of the type will involve - -- use of the secondary stack. If T is a record type, this is true - -- if the expression for some component uses the secondary stack, e.g. - -- through a call to a function that returns an unconstrained value. - -- False if T is controlled, because cleanups occur elsewhere. - - ------------- - -- Uses_SS -- - ------------- - - function Uses_SS (T : Entity_Id) return Boolean is - Comp : Entity_Id; - Expr : Node_Id; - Full_Type : Entity_Id := Underlying_Type (T); - - begin - -- Normally we want to use the underlying type, but if it's not set - -- then continue with T. - - if not Present (Full_Type) then - Full_Type := T; - end if; - - if Is_Controlled (Full_Type) then - return False; - - elsif Is_Array_Type (Full_Type) then - return Uses_SS (Component_Type (Full_Type)); - - elsif Is_Record_Type (Full_Type) then - Comp := First_Component (Full_Type); - while Present (Comp) loop - if Ekind (Comp) = E_Component - and then Nkind (Parent (Comp)) = N_Component_Declaration - then - -- The expression for a dynamic component may be rewritten - -- as a dereference, so retrieve original node. - - Expr := Original_Node (Expression (Parent (Comp))); - - -- Return True if the expression is a call to a function - -- (including an attribute function such as Image) with - -- a result that requires a transient scope. - - if (Nkind (Expr) = N_Function_Call - or else (Nkind (Expr) = N_Attribute_Reference - and then Present (Expressions (Expr)))) - and then Requires_Transient_Scope (Etype (Expr)) - then - return True; - - elsif Uses_SS (Etype (Comp)) then - return True; - end if; - end if; - - Next_Component (Comp); - end loop; - - return False; - - else - return False; - end if; - end Uses_SS; - - -- Start of processing for Check_Initialization_Call - - begin - -- Establish a transient scope if the type needs it - - if Uses_SS (Typ) then - Establish_Transient_Scope (First_Actual (N), Sec_Stack => True); - end if; - end Check_Initialization_Call; - - ------------------------------ - -- Check_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 not Is_Overloaded (N) then - return - Ekind (Etype (N)) = E_Subprogram_Type - and then Base_Type (Etype (Etype (N))) /= Standard_Void_Type; - else - Get_First_Interp (N, I, It); - while Present (It.Typ) loop - if Ekind (It.Typ) /= E_Subprogram_Type - or else Base_Type (Etype (It.Typ)) = Standard_Void_Type - then - return False; - end if; - - Get_Next_Interp (I, It); - end loop; - - return True; - end if; - end Prefix_Is_Access_Subp; - - -- Start of processing for Check_Parameterless_Call - - begin - -- Defend against junk stuff if errors already detected - - if Total_Errors_Detected /= 0 then - if Nkind (N) in N_Has_Etype and then Etype (N) = Any_Type then - return; - elsif Nkind (N) in N_Has_Chars - and then Chars (N) in Error_Name_Or_No_Name - then - return; - end if; - - Require_Entity (N); - end if; - - -- If the context expects a value, and the name is a procedure, this is - -- most likely a missing 'Access. Don't try to resolve the parameterless - -- call, error will be caught when the outer call is analyzed. - - if Is_Entity_Name (N) - and then Ekind (Entity (N)) = E_Procedure - and then not Is_Overloaded (N) - and then - Nkind_In (Parent (N), N_Parameter_Association, - N_Function_Call, - N_Procedure_Call_Statement) - then - return; - end if; - - -- Rewrite as call if overloadable entity that is (or could be, in the - -- overloaded case) a function call. If we know for sure that the entity - -- is an enumeration literal, we do not rewrite it. - - if (Is_Entity_Name (N) - 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 deference 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))) = E_Entry - or else - Ekind (Entity (Selector_Name (N))) = 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 - Nam := New_Copy (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)); - end if; - end Check_Parameterless_Call; - - ----------------------------- - -- Is_Definite_Access_Type -- - ----------------------------- - - function Is_Definite_Access_Type (E : Entity_Id) return Boolean is - Btyp : constant Entity_Id := Base_Type (E); - begin - return Ekind (Btyp) = E_Access_Type - or else (Ekind (Btyp) = E_Access_Subprogram_Type - and then Comes_From_Source (Btyp)); - end Is_Definite_Access_Type; - - ---------------------- - -- Is_Predefined_Op -- - ---------------------- - - function Is_Predefined_Op (Nam : Entity_Id) return Boolean is - begin - return Is_Intrinsic_Subprogram (Nam) - and then not Is_Generic_Instance (Nam) - and then Chars (Nam) in Any_Operator_Name - and then (No (Alias (Nam)) - or else Is_Predefined_Op (Alias (Nam))); - end Is_Predefined_Op; - - ----------------------------- - -- Make_Call_Into_Operator -- - ----------------------------- - - procedure Make_Call_Into_Operator - (N : Node_Id; - Typ : Entity_Id; - Op_Id : Entity_Id) - is - Op_Name : constant Name_Id := Chars (Op_Id); - Act1 : Node_Id := First_Actual (N); - Act2 : Node_Id := Next_Actual (Act1); - Error : Boolean := False; - Func : constant Entity_Id := Entity (Name (N)); - Is_Binary : constant Boolean := Present (Act2); - Op_Node : Node_Id; - Opnd_Type : Entity_Id; - Orig_Type : Entity_Id := Empty; - Pack : Entity_Id; - - type Kind_Test is access function (E : Entity_Id) return Boolean; - - function Operand_Type_In_Scope (S : Entity_Id) return Boolean; - -- If the operand is not universal, and the operator is given by a - -- 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 the package Pack that contains - -- the operator. - - --------------------------- - -- Operand_Type_In_Scope -- - --------------------------- - - function Operand_Type_In_Scope (S : Entity_Id) return Boolean is - Nod : constant Node_Id := Right_Opnd (Op_Node); - I : Interp_Index; - It : Interp; - - begin - if not Is_Overloaded (Nod) then - return Scope (Base_Type (Etype (Nod))) = S; - - else - Get_First_Interp (Nod, I, It); - while Present (It.Typ) loop - if Scope (Base_Type (It.Typ)) = S then - return True; - end if; - - Get_Next_Interp (I, It); - end loop; - - return False; - end if; - end Operand_Type_In_Scope; - - --------------- - -- Type_In_P -- - --------------- - - function Type_In_P (Test : Kind_Test) return Entity_Id is - E : Entity_Id; - - function In_Decl return Boolean; - -- Verify that node is not part of the type declaration for the - -- candidate type, which would otherwise be invisible. - - ------------- - -- In_Decl -- - ------------- - - function In_Decl return Boolean is - Decl_Node : constant Node_Id := Parent (E); - N2 : Node_Id; - - begin - N2 := N; - - if Etype (E) = Any_Type then - return True; - - elsif No (Decl_Node) then - return False; - - else - while Present (N2) - and then Nkind (N2) /= N_Compilation_Unit - loop - if N2 = Decl_Node then - return True; - else - N2 := Parent (N2); - end if; - end loop; - - return False; - end if; - end In_Decl; - - -- Start of processing for Type_In_P - - begin - -- If the context type is declared in the prefix package, this - -- is the desired base type. - - if Scope (Base_Type (Typ)) = Pack - and then Test (Typ) - then - return Base_Type (Typ); - - else - E := First_Entity (Pack); - while Present (E) loop - if Test (E) - and then not In_Decl - then - return E; - end if; - - Next_Entity (E); - end loop; - - return Empty; - end if; - end Type_In_P; - - -- Start of processing for Make_Call_Into_Operator - - begin - Op_Node := New_Node (Operator_Kind (Op_Name, Is_Binary), Sloc (N)); - - -- Binary operator - - if Is_Binary then - Set_Left_Opnd (Op_Node, Relocate_Node (Act1)); - Set_Right_Opnd (Op_Node, Relocate_Node (Act2)); - Save_Interps (Act1, Left_Opnd (Op_Node)); - Save_Interps (Act2, Right_Opnd (Op_Node)); - Act1 := Left_Opnd (Op_Node); - Act2 := Right_Opnd (Op_Node); - - -- Unary operator - - else - Set_Right_Opnd (Op_Node, Relocate_Node (Act1)); - Save_Interps (Act1, Right_Opnd (Op_Node)); - Act1 := Right_Opnd (Op_Node); - end if; - - -- If the operator is denoted by an expanded name, and the prefix is - -- not Standard, but the operator is a predefined one whose scope is - -- Standard, then this is an implicit_operator, inserted as an - -- interpretation by the procedure of the same name. This procedure - -- overestimates the presence of implicit operators, because it does - -- not examine the type of the operands. Verify now that the operand - -- type appears in the given scope. If right operand is universal, - -- check the other operand. In the case of concatenation, either - -- argument can be the component type, so check the type of the result. - -- If both arguments are literals, look for a type of the right kind - -- defined in the given scope. This elaborate nonsense is brought to - -- you courtesy of b33302a. The type itself must be frozen, so we must - -- find the type of the proper class in the given scope. - - -- A final wrinkle is the multiplication operator for fixed point - -- types, which is defined in Standard only, and not in the scope of - -- the fixed_point type itself. - - if Nkind (Name (N)) = N_Expanded_Name then - Pack := Entity (Prefix (Name (N))); - - -- If 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 = Name_Op_Multiply - or else Op_Name = Name_Op_Divide) - and then Is_Fixed_Point_Type (Etype (Left_Opnd (Op_Node))) - and then Is_Fixed_Point_Type (Etype (Right_Opnd (Op_Node))) - then - if Pack /= Standard_Standard then - Error := True; - end if; - - -- Ada 2005, AI-420: Predefined equality on Universal_Access - -- is available. - - elsif Ada_Version >= Ada_05 - and then (Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne) - and then Ekind (Etype (Act1)) = E_Anonymous_Access_Type - then - null; - - else - Opnd_Type := Base_Type (Etype (Right_Opnd (Op_Node))); - - if Op_Name = Name_Op_Concat then - Opnd_Type := Base_Type (Typ); - - elsif (Scope (Opnd_Type) = Standard_Standard - and then Is_Binary) - or else (Nkind (Right_Opnd (Op_Node)) = N_Attribute_Reference - and then Is_Binary - and then not Comes_From_Source (Opnd_Type)) - then - Opnd_Type := Base_Type (Etype (Left_Opnd (Op_Node))); - end if; - - if Scope (Opnd_Type) = Standard_Standard then - - -- Verify that the scope contains a type that corresponds to - -- the given literal. Optimize the case where Pack is Standard. - - if Pack /= Standard_Standard then - - if Opnd_Type = Universal_Integer then - Orig_Type := Type_In_P (Is_Integer_Type'Access); - - elsif Opnd_Type = Universal_Real then - Orig_Type := Type_In_P (Is_Real_Type'Access); - - elsif Opnd_Type = Any_String then - Orig_Type := Type_In_P (Is_String_Type'Access); - - elsif Opnd_Type = Any_Access then - Orig_Type := Type_In_P (Is_Definite_Access_Type'Access); - - elsif Opnd_Type = Any_Composite then - Orig_Type := Type_In_P (Is_Composite_Type'Access); - - if Present (Orig_Type) then - if Has_Private_Component (Orig_Type) then - Orig_Type := Empty; - else - Set_Etype (Act1, Orig_Type); - - if Is_Binary then - Set_Etype (Act2, Orig_Type); - end if; - end if; - end if; - - else - Orig_Type := Empty; - end if; - - Error := No (Orig_Type); - end if; - - elsif Ekind (Opnd_Type) = E_Allocator_Type - and then No (Type_In_P (Is_Definite_Access_Type'Access)) - then - Error := True; - - -- If the type is defined elsewhere, and the operator is not - -- defined in the given scope (by a renaming declaration, e.g.) - -- then this is an error as well. If an extension of System is - -- present, and the type may be defined there, Pack must be - -- System itself. - - elsif Scope (Opnd_Type) /= Pack - and then Scope (Op_Id) /= Pack - and then (No (System_Aux_Id) - or else Scope (Opnd_Type) /= System_Aux_Id - or else Pack /= Scope (System_Aux_Id)) - then - if not Is_Overloaded (Right_Opnd (Op_Node)) then - Error := True; - else - Error := not Operand_Type_In_Scope (Pack); - end if; - - elsif Pack = Standard_Standard - and then not Operand_Type_In_Scope (Standard_Standard) - then - Error := True; - end if; - end if; - - if Error then - Error_Msg_Node_2 := Pack; - Error_Msg_NE - ("& not declared in&", N, Selector_Name (Name (N))); - Set_Etype (N, Any_Type); - return; - 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 = Name_Op_Eq or else Op_Name = Name_Op_Ne) - and then Ekind (Func) = E_Function - and then Is_Overloaded (Act1) - then - Resolve (Act1, Base_Type (Etype (First_Formal (Func)))); - Resolve (Act2, Base_Type (Etype (First_Formal (Func)))); - end if; - - Set_Entity (Op_Node, Op_Id); - Generate_Reference (Op_Id, N, ' '); - - -- Do rewrite setting Comes_From_Source on the result if the original - -- call came from source. Although it is not strictly the case that the - -- operator as such comes from the source, logically it corresponds - -- exactly to the function call in the source, so it should be marked - -- this way (e.g. to make sure that validity checks work fine). - - declare - CS : constant Boolean := Comes_From_Source (N); - begin - Rewrite (N, Op_Node); - Set_Comes_From_Source (N, CS); - end; - - -- If this is an arithmetic operator and the result type is private, - -- the operands and the result must be wrapped in conversion to - -- expose the underlying numeric type and expand the proper checks, - -- e.g. on division. - - if Is_Private_Type (Typ) then - case Nkind (N) is - when N_Op_Add | N_Op_Subtract | N_Op_Multiply | N_Op_Divide | - N_Op_Expon | N_Op_Mod | N_Op_Rem => - Resolve_Intrinsic_Operator (N, Typ); - - when N_Op_Plus | N_Op_Minus | N_Op_Abs => - Resolve_Intrinsic_Unary_Operator (N, Typ); - - when others => - Resolve (N, Typ); - end case; - else - Resolve (N, Typ); - end if; - - -- For predefined operators on literals, the operation freezes - -- their type. - - if Present (Orig_Type) then - Set_Etype (Act1, Orig_Type); - Freeze_Expression (Act1); - 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 - if Is_Binary then - if Op_Name = Name_Op_And then - Kind := N_Op_And; - elsif Op_Name = Name_Op_Or then - Kind := N_Op_Or; - elsif Op_Name = Name_Op_Xor then - Kind := N_Op_Xor; - elsif Op_Name = Name_Op_Eq then - Kind := N_Op_Eq; - elsif Op_Name = Name_Op_Ne then - Kind := N_Op_Ne; - elsif Op_Name = Name_Op_Lt then - Kind := N_Op_Lt; - elsif Op_Name = Name_Op_Le then - Kind := N_Op_Le; - elsif Op_Name = Name_Op_Gt then - Kind := N_Op_Gt; - elsif Op_Name = Name_Op_Ge then - Kind := N_Op_Ge; - elsif Op_Name = Name_Op_Add then - Kind := N_Op_Add; - elsif Op_Name = Name_Op_Subtract then - Kind := N_Op_Subtract; - elsif Op_Name = Name_Op_Concat then - Kind := N_Op_Concat; - elsif Op_Name = Name_Op_Multiply then - Kind := N_Op_Multiply; - elsif Op_Name = Name_Op_Divide then - Kind := N_Op_Divide; - elsif Op_Name = Name_Op_Mod then - Kind := N_Op_Mod; - elsif Op_Name = Name_Op_Rem then - Kind := N_Op_Rem; - elsif Op_Name = Name_Op_Expon then - Kind := N_Op_Expon; - else - raise Program_Error; - end if; - - -- Unary operators - - else - if Op_Name = Name_Op_Add then - Kind := N_Op_Plus; - elsif Op_Name = Name_Op_Subtract then - Kind := N_Op_Minus; - elsif Op_Name = Name_Op_Abs then - Kind := N_Op_Abs; - elsif Op_Name = Name_Op_Not then - Kind := N_Op_Not; - else - raise Program_Error; - end if; - end if; - - return Kind; - end Operator_Kind; - - ---------------------------- - -- Preanalyze_And_Resolve -- - ---------------------------- - - procedure Preanalyze_And_Resolve (N : Node_Id; T : Entity_Id) is - Save_Full_Analysis : constant Boolean := Full_Analysis; - - begin - Full_Analysis := False; - Expander_Mode_Save_And_Set (False); - - -- We suppress all checks for this analysis, since the checks will - -- be applied properly, and in the right location, when the default - -- expression is reanalyzed and reexpanded later on. - - Analyze_And_Resolve (N, T, Suppress => All_Checks); - - Expander_Mode_Restore; - Full_Analysis := Save_Full_Analysis; - end Preanalyze_And_Resolve; - - -- Version without context type - - procedure Preanalyze_And_Resolve (N : Node_Id) is - Save_Full_Analysis : constant Boolean := Full_Analysis; - - begin - Full_Analysis := False; - Expander_Mode_Save_And_Set (False); - - Analyze (N); - Resolve (N, Etype (N), Suppress => All_Checks); - - Expander_Mode_Restore; - Full_Analysis := Save_Full_Analysis; - end Preanalyze_And_Resolve; - - ---------------------------------- - -- Replace_Actual_Discriminants -- - ---------------------------------- - - procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Tsk : Node_Id := Empty; - - function Process_Discr (Nod : Node_Id) return Traverse_Result; - - ------------------- - -- Process_Discr -- - ------------------- - - function Process_Discr (Nod : Node_Id) return Traverse_Result is - Ent : Entity_Id; - - begin - if Nkind (Nod) = N_Identifier then - Ent := Entity (Nod); - - if Present (Ent) - and then Ekind (Ent) = E_Discriminant - then - Rewrite (Nod, - Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Tsk, New_Sloc => Loc), - Selector_Name => Make_Identifier (Loc, Chars (Ent)))); - - Set_Etype (Nod, Etype (Ent)); - end if; - - end if; - - return OK; - end Process_Discr; - - procedure Replace_Discrs is new Traverse_Proc (Process_Discr); - - -- Start of processing for Replace_Actual_Discriminants - - begin - if not Expander_Active then - return; - end if; - - if Nkind (Name (N)) = N_Selected_Component then - Tsk := Prefix (Name (N)); - - elsif Nkind (Name (N)) = N_Indexed_Component then - Tsk := Prefix (Prefix (Name (N))); - end if; - - if No (Tsk) then - return; - else - Replace_Discrs (Default); - end if; - end Replace_Actual_Discriminants; - - ------------- - -- Resolve -- - ------------- - - procedure Resolve (N : Node_Id; Typ : Entity_Id) is - Ambiguous : Boolean := False; - Ctx_Type : Entity_Id := Typ; - Expr_Type : Entity_Id := Empty; -- prevent junk warning - Err_Type : Entity_Id := Empty; - Found : Boolean := False; - From_Lib : Boolean; - I : Interp_Index; - I1 : Interp_Index := 0; -- prevent junk warning - It : Interp; - It1 : Interp; - Seen : Entity_Id := Empty; -- prevent junk warning - - function Comes_From_Predefined_Lib_Unit (Nod : Node_Id) return Boolean; - -- Determine whether a node comes from a predefined library unit or - -- Standard. - - procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id); - -- Try and fix up a literal so that it matches its expected type. New - -- literals are manufactured if necessary to avoid cascaded errors. - - procedure Resolution_Failed; - -- Called when attempt at resolving current expression fails - - ------------------------------------ - -- Comes_From_Predefined_Lib_Unit -- - ------------------------------------- - - function Comes_From_Predefined_Lib_Unit (Nod : Node_Id) return Boolean is - begin - return - Sloc (Nod) = Standard_Location - or else Is_Predefined_File_Name (Unit_File_Name ( - Get_Source_Unit (Sloc (Nod)))); - end Comes_From_Predefined_Lib_Unit; - - -------------------- - -- Patch_Up_Value -- - -------------------- - - procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id) is - begin - if Nkind (N) = N_Integer_Literal - and then Is_Real_Type (Typ) - then - Rewrite (N, - Make_Real_Literal (Sloc (N), - Realval => UR_From_Uint (Intval (N)))); - Set_Etype (N, Universal_Real); - Set_Is_Static_Expression (N); - - elsif Nkind (N) = N_Real_Literal - and then Is_Integer_Type (Typ) - then - Rewrite (N, - Make_Integer_Literal (Sloc (N), - Intval => UR_To_Uint (Realval (N)))); - Set_Etype (N, Universal_Integer); - Set_Is_Static_Expression (N); - - elsif Nkind (N) = N_String_Literal - and then Is_Character_Type (Typ) - then - Set_Character_Literal_Name (Char_Code (Character'Pos ('A'))); - Rewrite (N, - Make_Character_Literal (Sloc (N), - Chars => Name_Find, - Char_Literal_Value => - UI_From_Int (Character'Pos ('A')))); - Set_Etype (N, Any_Character); - Set_Is_Static_Expression (N); - - elsif Nkind (N) /= N_String_Literal - and then Is_String_Type (Typ) - then - Rewrite (N, - Make_String_Literal (Sloc (N), - Strval => End_String)); - - elsif Nkind (N) = N_Range then - Patch_Up_Value (Low_Bound (N), Typ); - Patch_Up_Value (High_Bound (N), Typ); - end if; - end Patch_Up_Value; - - ----------------------- - -- Resolution_Failed -- - ----------------------- - - procedure Resolution_Failed is - begin - Patch_Up_Value (N, Typ); - Set_Etype (N, Typ); - Debug_A_Exit ("resolving ", N, " (done, resolution failed)"); - Set_Is_Overloaded (N, False); - - -- The caller will return without calling the expander, so we need - -- to set the analyzed flag. Note that it is fine to set Analyzed - -- to True even if we are in the middle of a shallow analysis, - -- (see the spec of sem for more details) since this is an error - -- situation anyway, and there is no point in repeating the - -- analysis later (indeed it won't work to repeat it later, since - -- we haven't got a clear resolution of which entity is being - -- referenced.) - - Set_Analyzed (N, True); - return; - end Resolution_Failed; - - -- Start of processing for Resolve - - begin - if N = Error then - return; - end if; - - -- Access attribute on remote subprogram cannot be used for - -- a non-remote access-to-subprogram type. - - if Nkind (N) = N_Attribute_Reference - and then (Attribute_Name (N) = Name_Access - or else Attribute_Name (N) = Name_Unrestricted_Access - or else Attribute_Name (N) = Name_Unchecked_Access) - and then Comes_From_Source (N) - and then Is_Entity_Name (Prefix (N)) - and then Is_Subprogram (Entity (Prefix (N))) - and then Is_Remote_Call_Interface (Entity (Prefix (N))) - and then not Is_Remote_Access_To_Subprogram_Type (Typ) - then - Error_Msg_N - ("prefix must statically denote a non-remote subprogram", N); - end if; - - From_Lib := Comes_From_Predefined_Lib_Unit (N); - - -- If the context is a Remote_Access_To_Subprogram, access attributes - -- must be resolved with the corresponding fat pointer. There is no need - -- to check for the attribute name since the return type of an - -- attribute is never a remote type. - - if Nkind (N) = N_Attribute_Reference - and then Comes_From_Source (N) - and then (Is_Remote_Call_Interface (Typ) - or else Is_Remote_Types (Typ)) - then - declare - Attr : constant Attribute_Id := - Get_Attribute_Id (Attribute_Name (N)); - Pref : constant Node_Id := Prefix (N); - Decl : Node_Id; - Spec : Node_Id; - Is_Remote : Boolean := True; - - begin - -- Check that Typ is a remote access-to-subprogram type - - if Is_Remote_Access_To_Subprogram_Type (Typ) then - -- Prefix (N) must statically denote a remote subprogram - -- declared in a package specification. - - if Attr = Attribute_Access then - Decl := Unit_Declaration_Node (Entity (Pref)); - - if Nkind (Decl) = N_Subprogram_Body then - Spec := Corresponding_Spec (Decl); - - if not No (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; - end if; - - -- If we are generating code for a distributed program. - -- perform semantic checks against the corresponding - -- remote entities. - - if (Attr = Attribute_Access - or else Attr = Attribute_Unchecked_Access - or else Attr = Attribute_Unrestricted_Access) - and then 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; - end if; - - Debug_A_Entry ("resolving ", N); - - 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)"); - return; - - -- Return if type = Any_Type (previous error encountered) - - elsif Etype (N) = Any_Type then - Debug_A_Exit ("resolving ", N, " (done, Etype = Any_Type)"); - return; - end if; - - Check_Parameterless_Call (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. - - if not Is_Overloaded (N) then - Found := Covers (Typ, Etype (N)); - Expr_Type := Etype (N); - - -- In the overloaded case, we must select the interpretation that - -- is compatible with the context (i.e. the type passed to Resolve) - - else - -- Loop through possible interpretations - - Get_First_Interp (N, I, It); - Interp_Loop : while Present (It.Typ) loop - - -- 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_05 - and then It.Typ = Typ - and then Typ /= Universal_Integer - and then Typ /= Universal_Real - and then Present (It.Abstract_Op) - then - 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. - - if From_Lib - and then not Comes_From_Predefined_Lib_Unit (It.Nam) - then - goto Continue; - end if; - - Error_Msg_Sloc := Sloc (Seen); - It1 := Disambiguate (N, I1, I, Typ); - - -- Disambiguation has succeeded. Skip the remaining - -- interpretations. - - if It1 /= No_Interp then - Seen := It1.Nam; - Expr_Type := It1.Typ; - - while Present (It.Typ) loop - Get_Next_Interp (I, It); - end loop; - - else - -- Before we issue an ambiguity complaint, check for - -- the case of a subprogram call where at least one - -- of the arguments is Any_Type, and if so, suppress - -- the message, since it is a cascaded error. - - if Nkind_In (N, N_Function_Call, - N_Procedure_Call_Statement) - then - declare - A : Node_Id; - E : Node_Id; - - begin - A := First_Actual (N); - while Present (A) loop - E := A; - - if Nkind (E) = N_Parameter_Association then - E := Explicit_Actual_Parameter (E); - end if; - - if Etype (E) = Any_Type then - if Debug_Flag_V then - Write_Str ("Any_Type in call"); - Write_Eol; - end if; - - exit Interp_Loop; - end if; - - Next_Actual (A); - end loop; - end; - - elsif Nkind (N) in N_Binary_Op - and then (Etype (Left_Opnd (N)) = Any_Type - or else Etype (Right_Opnd (N)) = Any_Type) - then - exit Interp_Loop; - - elsif Nkind (N) in N_Unary_Op - and then Etype (Right_Opnd (N)) = Any_Type - then - exit Interp_Loop; - end if; - - -- Not that special case, so issue message using the - -- flag Ambiguous to control printing of the header - -- message only at the start of an ambiguous set. - - if not Ambiguous then - if Nkind (N) = N_Function_Call - and then Nkind (Name (N)) = N_Explicit_Dereference - then - Error_Msg_N - ("ambiguous expression " - & "(cannot resolve indirect call)!", N); - else - Error_Msg_NE - ("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 ("\\possible interpretation#!", N); - 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. - -- Indicate as well 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 ("\\possible interpretation#!", N); - end if; - - end if; - end if; - - -- We have a matching interpretation, Expr_Type is the type - -- from this interpretation, and Seen is the entity. - - -- For an operator, just set the entity name. The type will be - -- set by the specific operator resolution routine. - - if Nkind (N) in N_Op then - Set_Entity (N, Seen); - Generate_Reference (Seen, N); - - elsif Nkind (N) = N_Character_Literal then - Set_Etype (N, Expr_Type); - - -- For an explicit dereference, attribute reference, range, - -- short-circuit form (which is not an operator node), or call - -- with a name that is an explicit dereference, there is - -- nothing to be done at this point. - - elsif Nkind_In (N, N_Explicit_Dereference, - N_Attribute_Reference, - N_And_Then, - N_Indexed_Component, - N_Or_Else, - N_Range, - N_Selected_Component, - N_Slice) - or else Nkind (Name (N)) = N_Explicit_Dereference - then - null; - - -- For procedure or function calls, set the type of the name, - -- and also the entity pointer for the prefix - - elsif Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call) - and then (Is_Entity_Name (Name (N)) - or else Nkind (Name (N)) = N_Operator_Symbol) - then - Set_Etype (Name (N), Expr_Type); - Set_Entity (Name (N), Seen); - Generate_Reference (Seen, Name (N)); - - elsif Nkind (N) = N_Function_Call - and then Nkind (Name (N)) = N_Selected_Component - then - Set_Etype (Name (N), Expr_Type); - Set_Entity (Selector_Name (Name (N)), Seen); - Generate_Reference (Seen, Selector_Name (Name (N))); - - -- For all other cases, just set the type of the Name - - else - Set_Etype (Name (N), Expr_Type); - end if; - - end if; - - <<Continue>> - - -- Move to next interpretation - - exit Interp_Loop when No (It.Typ); - - Get_Next_Interp (I, It); - end loop Interp_Loop; - end if; - - -- At this stage Found indicates whether or not an acceptable - -- interpretation exists. If not, then we have an error, except - -- that if the context is Any_Type as a result of some other error, - -- then we suppress the error report. - - if not Found then - if Typ /= Any_Type then - - -- If type we are looking for is Void, then this is the procedure - -- call case, and the error is simply that what we gave is not a - -- procedure name (we think of procedure calls as expressions with - -- types internally, but the user doesn't think of them this way!) - - if Typ = Standard_Void_Type then - - -- Special case message if function used as a procedure - - if Nkind (N) = N_Procedure_Call_Statement - and then Is_Entity_Name (Name (N)) - and then Ekind (Entity (Name (N))) = E_Function - then - Error_Msg_NE - ("cannot use function & in a procedure call", - Name (N), Entity (Name (N))); - - -- Otherwise give general message (not clear what cases this - -- covers, but no harm in providing for them!) - - else - Error_Msg_N ("expect procedure name in procedure call", N); - end if; - - Found := True; - - -- Otherwise we do have a subexpression with the wrong type - - -- Check for the case of an allocator which uses an access type - -- instead of the designated type. This is a common error and we - -- specialize the message, posting an error on the operand of the - -- allocator, complaining that we expected the designated type of - -- the allocator. - - elsif Nkind (N) = N_Allocator - and then Ekind (Typ) in Access_Kind - and then Ekind (Etype (N)) in Access_Kind - and then Designated_Type (Etype (N)) = Typ - then - Wrong_Type (Expression (N), Designated_Type (Typ)); - Found := True; - - -- Check for view mismatch on Null in instances, for which the - -- view-swapping mechanism has no identifier. - - elsif (In_Instance or else In_Inlined_Body) - and then (Nkind (N) = N_Null) - and then Is_Private_Type (Typ) - and then Is_Access_Type (Full_View (Typ)) - then - Resolve (N, Full_View (Typ)); - Set_Etype (N, Typ); - return; - - -- Check for an aggregate. Sometimes we can get bogus aggregates - -- from misuse of parentheses, and we are about to complain about - -- the aggregate without even looking inside it. - - -- Instead, if we have an aggregate of type Any_Composite, then - -- analyze and resolve the component fields, and then only issue - -- another message if we get no errors doing this (otherwise - -- assume that the errors in the aggregate caused the problem). - - elsif Nkind (N) = N_Aggregate - and then Etype (N) = Any_Composite - then - -- Disable expansion in any case. If there is a type mismatch - -- it may be fatal to try to expand the aggregate. The flag - -- would otherwise be set to false when the error is posted. - - Expander_Active := False; - - declare - procedure Check_Aggr (Aggr : Node_Id); - -- Check one aggregate, and set Found to True if we have a - -- definite error in any of its elements - - procedure Check_Elmt (Aelmt : Node_Id); - -- Check one element of aggregate and set Found to True if - -- we definitely have an error in the element. - - ---------------- - -- Check_Aggr -- - ---------------- - - procedure Check_Aggr (Aggr : Node_Id) is - Elmt : Node_Id; - - begin - if Present (Expressions (Aggr)) then - Elmt := First (Expressions (Aggr)); - while Present (Elmt) loop - Check_Elmt (Elmt); - Next (Elmt); - end loop; - end if; - - if Present (Component_Associations (Aggr)) then - Elmt := First (Component_Associations (Aggr)); - while Present (Elmt) loop - - -- If this is a default-initialized component, then - -- there is nothing to check. The box will be - -- replaced by the appropriate call during late - -- expansion. - - if not Box_Present (Elmt) then - Check_Elmt (Expression (Elmt)); - end if; - - Next (Elmt); - end loop; - end if; - end Check_Aggr; - - ---------------- - -- Check_Elmt -- - ---------------- - - procedure Check_Elmt (Aelmt : Node_Id) is - begin - -- If we have a nested aggregate, go inside it (to - -- attempt a naked analyze-resolve of the aggregate - -- can cause undesirable cascaded errors). Do not - -- resolve expression if it needs a type from context, - -- as for integer * fixed expression. - - if Nkind (Aelmt) = N_Aggregate then - Check_Aggr (Aelmt); - - else - Analyze (Aelmt); - - if not Is_Overloaded (Aelmt) - and then Etype (Aelmt) /= Any_Fixed - then - Resolve (Aelmt); - end if; - - if Etype (Aelmt) = Any_Type then - Found := True; - end if; - end if; - end Check_Elmt; - - begin - Check_Aggr (N); - end; - end if; - - -- If an error message was issued already, Found got reset - -- to True, so if it is still False, issue the standard - -- Wrong_Type message. - - if not Found then - if Is_Overloaded (N) - and then Nkind (N) = N_Function_Call - then - declare - Subp_Name : Node_Id; - begin - if Is_Entity_Name (Name (N)) then - Subp_Name := Name (N); - - elsif Nkind (Name (N)) = N_Selected_Component then - - -- Protected operation: retrieve operation name - - Subp_Name := Selector_Name (Name (N)); - else - raise Program_Error; - end if; - - Error_Msg_Node_2 := Typ; - Error_Msg_NE ("no visible interpretation of&" & - " matches expected type&", N, Subp_Name); - end; - - if All_Errors_Mode then - declare - Index : Interp_Index; - It : Interp; - - begin - Error_Msg_N ("\\possible interpretations:", N); - - Get_First_Interp (Name (N), Index, It); - while Present (It.Nam) loop - Error_Msg_Sloc := Sloc (It.Nam); - Error_Msg_Node_2 := It.Nam; - Error_Msg_NE - ("\\ type& for & declared#", N, It.Typ); - Get_Next_Interp (Index, It); - end loop; - end; - - else - Error_Msg_N ("\use -gnatf for details", N); - end if; - else - Wrong_Type (N, Typ); - end if; - end if; - end if; - - Resolution_Failed; - return; - - -- Test if we have more than one interpretation for the context - - elsif Ambiguous then - Resolution_Failed; - return; - - -- Here we have an acceptable interpretation for the context - - else - -- 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_And_Then | N_Or_Else - => Resolve_Short_Circuit (N, Ctx_Type); - - when N_Attribute_Reference - => Resolve_Attribute (N, Ctx_Type); - - when N_Character_Literal - => Resolve_Character_Literal (N, Ctx_Type); - - when N_Conditional_Expression - => Resolve_Conditional_Expression (N, Ctx_Type); - - when N_Expanded_Name - => Resolve_Entity_Name (N, Ctx_Type); - - when N_Extension_Aggregate - => Resolve_Extension_Aggregate (N, Ctx_Type); - - when N_Explicit_Dereference - => Resolve_Explicit_Dereference (N, Ctx_Type); - - when N_Function_Call - => Resolve_Call (N, Ctx_Type); - - when N_Identifier - => Resolve_Entity_Name (N, Ctx_Type); - - when N_Indexed_Component - => Resolve_Indexed_Component (N, Ctx_Type); - - when N_Integer_Literal - => Resolve_Integer_Literal (N, Ctx_Type); - - when N_Membership_Test - => Resolve_Membership_Op (N, Ctx_Type); - - when N_Null => Resolve_Null (N, Ctx_Type); - - when N_Op_And | N_Op_Or | N_Op_Xor - => Resolve_Logical_Op (N, Ctx_Type); - - when N_Op_Eq | N_Op_Ne - => Resolve_Equality_Op (N, Ctx_Type); - - when N_Op_Lt | N_Op_Le | N_Op_Gt | N_Op_Ge - => Resolve_Comparison_Op (N, Ctx_Type); - - when N_Op_Not => Resolve_Op_Not (N, Ctx_Type); - - when N_Op_Add | N_Op_Subtract | N_Op_Multiply | - N_Op_Divide | N_Op_Mod | N_Op_Rem - - => Resolve_Arithmetic_Op (N, Ctx_Type); - - when N_Op_Concat => Resolve_Op_Concat (N, Ctx_Type); - - when N_Op_Expon => Resolve_Op_Expon (N, Ctx_Type); - - when N_Op_Plus | N_Op_Minus | N_Op_Abs - => Resolve_Unary_Op (N, Ctx_Type); - - when N_Op_Shift => Resolve_Shift (N, Ctx_Type); - - when N_Procedure_Call_Statement - => Resolve_Call (N, Ctx_Type); - - when N_Operator_Symbol - => Resolve_Operator_Symbol (N, Ctx_Type); - - when N_Qualified_Expression - => Resolve_Qualified_Expression (N, Ctx_Type); - - 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_Subprogram_Info - => Resolve_Subprogram_Info (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; - - -- 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). - - Freeze_Expression (N); - - -- Now we can do the expansion - - Expand (N); - end if; - end Resolve; - - ------------- - -- Resolve -- - ------------- - - -- Version with check(s) suppressed - - procedure Resolve (N : Node_Id; Typ : Entity_Id; Suppress : Check_Id) is - begin - if Suppress = All_Checks then - declare - Svg : constant Suppress_Array := Scope_Suppress; - begin - Scope_Suppress := (others => True); - Resolve (N, Typ); - Scope_Suppress := Svg; - end; - - else - declare - Svg : constant Boolean := Scope_Suppress (Suppress); - begin - Scope_Suppress (Suppress) := True; - Resolve (N, Typ); - Scope_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; - F : Entity_Id; - A_Typ : Entity_Id; - F_Typ : Entity_Id; - Prev : Node_Id := Empty; - Orig_A : Node_Id; - - procedure Check_Argument_Order; - -- Performs a check for the case where the actuals are all simple - -- identifiers that correspond to the formal names, but in the wrong - -- order, which is considered suspicious and cause for a warning. - - procedure Check_Prefixed_Call; - -- If the original node is an overloaded call in prefix notation, - -- insert an 'Access or a dereference as needed over the first actual. - -- Try_Object_Operation has already verified that there is a valid - -- interpretation, but the form of the actual can only be determined - -- once the primitive operation is identified. - - procedure Insert_Default; - -- If the actual is missing in a call, insert in the actuals list - -- an instance of the default expression. The insertion is always - -- a named association. - - 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. - - -------------------------- - -- Check_Argument_Order -- - -------------------------- - - procedure Check_Argument_Order is - begin - -- Nothing to do if no parameters, or original node is neither a - -- function call nor a procedure call statement (happens in the - -- operator-transformed-to-function call case), or the call does - -- not come from source, or this warning is off. - - if not Warn_On_Parameter_Order - or else - No (Parameter_Associations (N)) - or else - not Nkind_In (Original_Node (N), N_Procedure_Call_Statement, - N_Function_Call) - or else - not Comes_From_Source (N) - then - return; - end if; - - declare - Nargs : constant Nat := List_Length (Parameter_Associations (N)); - - begin - -- Nothing to do if only one parameter - - if Nargs < 2 then - return; - end if; - - -- Here if at least two arguments - - declare - Actuals : array (1 .. Nargs) of Node_Id; - Actual : Node_Id; - Formal : Node_Id; - - Wrong_Order : Boolean := False; - -- Set True if an out of order case is found - - begin - -- Collect identifier names of actuals, fail if any actual is - -- not a simple identifier, and record max length of name. - - Actual := First (Parameter_Associations (N)); - for J in Actuals'Range loop - if Nkind (Actual) /= N_Identifier then - return; - else - Actuals (J) := Actual; - Next (Actual); - end if; - end loop; - - -- If we got this far, all actuals are identifiers and the list - -- of their names is stored in the Actuals array. - - Formal := First_Formal (Nam); - for J in Actuals'Range loop - - -- If we ran out of formals, that's odd, probably an error - -- which will be detected elsewhere, but abandon the search. - - if No (Formal) then - return; - end if; - - -- If name matches and is in order OK - - if Chars (Formal) = Chars (Actuals (J)) then - null; - - else - -- If no match, see if it is elsewhere in list and if so - -- flag potential wrong order if type is compatible. - - for K in Actuals'Range loop - if Chars (Formal) = Chars (Actuals (K)) - and then - Has_Compatible_Type (Actuals (K), Etype (Formal)) - then - Wrong_Order := True; - goto Continue; - end if; - end loop; - - -- No match - - return; - end if; - - <<Continue>> Next_Formal (Formal); - end loop; - - -- If Formals left over, also probably an error, skip warning - - if Present (Formal) then - return; - end if; - - -- Here we give the warning if something was out of order - - if Wrong_Order then - Error_Msg_N - ("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-2005 4.3.1 (13))", - Prefix (Act), Nam); - end if; - - Rewrite (Act, - Make_Attribute_Reference (Loc, - Attribute_Name => Name_Access, - Prefix => Relocate_Node (Act))); - end if; - - Analyze (Act); - end if; - end Check_Prefixed_Call; - - -------------------- - -- Insert_Default -- - -------------------- - - procedure Insert_Default is - Actval : Node_Id; - Assoc : Node_Id; - - begin - -- Missing argument in call, nothing to insert - - if No (Default_Value (F)) then - return; - - else - -- Note that we do a full New_Copy_Tree, so that any associated - -- Itypes are properly copied. This may not be needed any more, - -- but it does no harm as a safety measure! Defaults of a generic - -- formal may be out of bounds of the corresponding actual (see - -- cc1311b) and an additional check may be required. - - Actval := - New_Copy_Tree - (Default_Value (F), - New_Scope => Current_Scope, - New_Sloc => Loc); - - if Is_Concurrent_Type (Scope (Nam)) - and then Has_Discriminants (Scope (Nam)) - then - Replace_Actual_Discriminants (N, Actval); - end if; - - if Is_Overloadable (Nam) - and then Present (Alias (Nam)) - then - if Base_Type (Etype (F)) /= Base_Type (Etype (Actval)) - and then not Is_Tagged_Type (Etype (F)) - then - -- If default is a real literal, do not introduce a - -- conversion whose effect may depend on the run-time - -- size of universal real. - - if Nkind (Actval) = N_Real_Literal then - Set_Etype (Actval, Base_Type (Etype (F))); - else - Actval := Unchecked_Convert_To (Etype (F), Actval); - end if; - end if; - - if Is_Scalar_Type (Etype (F)) then - Enable_Range_Check (Actval); - end if; - - Set_Parent (Actval, N); - - -- Resolve aggregates with their base type, to avoid scope - -- anomalies: the subtype was first built in the subprogram - -- declaration, and the current call may be nested. - - if Nkind (Actval) = N_Aggregate - and then Has_Discriminants (Etype (Actval)) - then - Analyze_And_Resolve (Actval, Base_Type (Etype (Actval))); - 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 Raises_Constraint_Error (Actval) 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; - - -- Start of processing for Resolve_Actuals - - begin - Check_Argument_Order; - - if Present (First_Actual (N)) then - Check_Prefixed_Call; - end if; - - A := First_Actual (N); - F := First_Formal (Nam); - while Present (F) loop - if No (A) and then Needs_No_Actuals (Nam) then - null; - - -- If we have an error in any actual or formal, indicated by - -- a type of Any_Type, then abandon resolution attempt, and - -- set result type to Any_Type. - - elsif (Present (A) and then Etype (A) = Any_Type) - or else Etype (F) = Any_Type - then - Set_Etype (N, Any_Type); - return; - 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 reference to the source entity may - -- be lost. - - if Present (A) - and then Is_Entity_Name (A) - and then Comes_From_Source (N) - then - Orig_A := Entity (A); - - if Present (Orig_A) then - if Is_Formal (Orig_A) - and then Ekind (F) /= E_In_Parameter - then - Generate_Reference (Orig_A, A, 'm'); - elsif not Is_Overloaded (A) then - Generate_Reference (Orig_A, A); - end if; - end if; - end if; - - if Present (A) - and then (Nkind (Parent (A)) /= N_Parameter_Association - or else - Chars (Selector_Name (Parent (A))) = Chars (F)) - then - -- If style checking mode on, check match of formal name - - if Style_Check then - if Nkind (Parent (A)) = N_Parameter_Association then - Check_Identifier (Selector_Name (Parent (A)), F); - end if; - end if; - - -- If the formal is Out or In_Out, do not resolve and expand the - -- conversion, because it is subsequently expanded into explicit - -- temporaries and assignments. However, the object of the - -- conversion can be resolved. An exception is the case of tagged - -- type conversion with a class-wide actual. In that case we want - -- the tag check to occur and no temporary will be needed (no - -- representation change can occur) and the parameter is passed by - -- reference, so we go ahead and resolve the type conversion. - -- Another exception is the case of reference to component or - -- subcomponent of a bit-packed array, in which case we want to - -- defer expansion to the point the in and out assignments are - -- performed. - - if Ekind (F) /= E_In_Parameter - and then Nkind (A) = N_Type_Conversion - and then not Is_Class_Wide_Type (Etype (Expression (A))) - then - if Ekind (F) = E_In_Out_Parameter - and then Is_Array_Type (Etype (F)) - then - if Has_Aliased_Components (Etype (Expression (A))) - /= Has_Aliased_Components (Etype (F)) - then - - -- In a view conversion, the conversion must be legal in - -- both directions, and thus both component types must be - -- aliased, or neither (4.6 (8)). - - -- The additional rule 4.6 (24.9.2) seems unduly - -- restrictive: the privacy requirement should not - -- apply to generic types, and should be checked in - -- an instance. ARG query is in order. - - Error_Msg_N - ("both component types in a view conversion must be" - & " aliased, or neither", A); - - elsif - not Same_Ancestor (Etype (F), Etype (Expression (A))) - then - if Is_By_Reference_Type (Etype (F)) - or else Is_By_Reference_Type (Etype (Expression (A))) - then - Error_Msg_N - ("view conversion between unrelated by reference " & - "array types not allowed (\'A'I-00246)", A); - else - declare - Comp_Type : constant Entity_Id := - Component_Type - (Etype (Expression (A))); - begin - if Comes_From_Source (A) - and then Ada_Version >= Ada_05 - and then - ((Is_Private_Type (Comp_Type) - and then not Is_Generic_Type (Comp_Type)) - or else Is_Tagged_Type (Comp_Type) - or else Is_Volatile (Comp_Type)) - then - Error_Msg_N - ("component type of a view conversion cannot" - & " be private, tagged, or volatile" - & " (RM 4.6 (24))", - Expression (A)); - end if; - end; - end if; - end if; - end if; - - if (Conversion_OK (A) - or else Valid_Conversion (A, Etype (A), Expression (A))) - and then not Is_Ref_To_Bit_Packed_Array (Expression (A)) - then - Resolve (Expression (A)); - end if; - - -- If the actual is a function call that returns a limited - -- unconstrained object that needs finalization, create a - -- transient scope for it, so that it can receive the proper - -- finalization list. - - elsif Nkind (A) = N_Function_Call - and then Is_Limited_Record (Etype (F)) - and then not Is_Constrained (Etype (F)) - and then Expander_Active - and then - (Is_Controlled (Etype (F)) or else Has_Task (Etype (F))) - then - Establish_Transient_Scope (A, False); - - else - if Nkind (A) = N_Type_Conversion - and then Is_Array_Type (Etype (F)) - and then not Same_Ancestor (Etype (F), Etype (Expression (A))) - and then - (Is_Limited_Type (Etype (F)) - or else Is_Limited_Type (Etype (Expression (A)))) - then - Error_Msg_N - ("conversion between unrelated limited array types " & - "not allowed (\A\I-00246)", A); - - if Is_Limited_Type (Etype (F)) then - Explain_Limited_Type (Etype (F), A); - end if; - - if Is_Limited_Type (Etype (Expression (A))) then - Explain_Limited_Type (Etype (Expression (A)), A); - end if; - end if; - - -- (Ada 2005: AI-251): If the actual is an allocator whose - -- directly designated type is a class-wide interface, we build - -- an anonymous access type to use it as the type of the - -- allocator. Later, when the subprogram call is expanded, if - -- the interface has a secondary dispatch table the expander - -- will add a type conversion to force the correct displacement - -- of the pointer. - - if Nkind (A) = N_Allocator then - declare - DDT : constant Entity_Id := - Directly_Designated_Type (Base_Type (Etype (F))); - - New_Itype : Entity_Id; - - begin - if Is_Class_Wide_Type (DDT) - and then Is_Interface (DDT) - then - New_Itype := Create_Itype (E_Anonymous_Access_Type, A); - Set_Etype (New_Itype, Etype (A)); - Set_Directly_Designated_Type (New_Itype, - Directly_Designated_Type (Etype (A))); - Set_Etype (A, New_Itype); - end if; - - -- Ada 2005, AI-162:If the actual is an allocator, the - -- innermost enclosing statement is the master of the - -- created object. This needs to be done with expansion - -- enabled only, otherwise the transient scope will not - -- be removed in the expansion of the wrapped construct. - - if (Is_Controlled (DDT) or else Has_Task (DDT)) - and then Expander_Active - then - Establish_Transient_Scope (A, False); - end if; - end; - end if; - - -- (Ada 2005): The call may be to a primitive operation of - -- a tagged synchronized type, declared outside of the type. - -- In this case the controlling actual must be converted to - -- its corresponding record type, which is the formal type. - -- The actual may be a subtype, either because of a constraint - -- or because it is a generic actual, so use base type to - -- locate concurrent type. - - A_Typ := Base_Type (Etype (A)); - F_Typ := Base_Type (Etype (F)); - - declare - Full_A_Typ : Entity_Id; - - begin - if Present (Full_View (A_Typ)) then - Full_A_Typ := Base_Type (Full_View (A_Typ)); - else - Full_A_Typ := A_Typ; - end if; - - -- Tagged synchronized type (case 1): the actual is a - -- concurrent type - - if Is_Concurrent_Type (A_Typ) - and then Corresponding_Record_Type (A_Typ) = F_Typ - then - Rewrite (A, - Unchecked_Convert_To - (Corresponding_Record_Type (A_Typ), A)); - Resolve (A, Etype (F)); - - -- Tagged synchronized type (case 2): the formal is a - -- concurrent type - - elsif Ekind (Full_A_Typ) = E_Record_Type - and then Present - (Corresponding_Concurrent_Type (Full_A_Typ)) - and then Is_Concurrent_Type (F_Typ) - and then Present (Corresponding_Record_Type (F_Typ)) - and then Full_A_Typ = Corresponding_Record_Type (F_Typ) - then - Resolve (A, Corresponding_Record_Type (F_Typ)); - - -- Common case - - else - Resolve (A, Etype (F)); - end if; - end; - end if; - - A_Typ := Etype (A); - F_Typ := Etype (F); - - -- For mode IN, if actual is an entity, and the type of the formal - -- has warnings suppressed, then we reset Never_Set_In_Source for - -- the calling entity. The reason for this is to catch cases like - -- GNAT.Spitbol.Patterns.Vstring_Var where the called subprogram - -- uses trickery to modify an IN parameter. - - if Ekind (F) = E_In_Parameter - and then Is_Entity_Name (A) - and then Present (Entity (A)) - and then Ekind (Entity (A)) = E_Variable - and then Has_Warnings_Off (F_Typ) - then - Set_Never_Set_In_Source (Entity (A), False); - end if; - - -- Perform error checks for IN and IN OUT parameters - - if Ekind (F) /= E_Out_Parameter then - - -- Check unset reference. For scalar parameters, it is clearly - -- wrong to pass an uninitialized value as either an IN or - -- IN-OUT parameter. For composites, it is also clearly an - -- error to pass a completely uninitialized value as an IN - -- parameter, but the case of IN OUT is trickier. We prefer - -- not to give a warning here. For example, suppose there is - -- a routine that sets some component of a record to False. - -- It is perfectly reasonable to make this IN-OUT and allow - -- either initialized or uninitialized records to be passed - -- in this case. - - -- For partially initialized composite values, we also avoid - -- warnings, since it is quite likely that we are passing a - -- partially initialized value and only the initialized fields - -- will in fact be read in the subprogram. - - if Is_Scalar_Type (A_Typ) - or else (Ekind (F) = E_In_Parameter - and then not Is_Partially_Initialized_Type (A_Typ)) - then - Check_Unset_Reference (A); - end if; - - -- In Ada 83 we cannot pass an OUT parameter as an IN or IN OUT - -- actual to a nested call, since this is case of reading an - -- out parameter, which is not allowed. - - if Ada_Version = Ada_83 - and then Is_Entity_Name (A) - and then Ekind (Entity (A)) = E_Out_Parameter - then - Error_Msg_N ("(Ada 83) illegal reading of out parameter", A); - end if; - end if; - - -- Case of OUT or IN OUT parameter - - if Ekind (F) /= E_In_Parameter then - - -- For an Out parameter, check for useless assignment. Note - -- that we can't set Last_Assignment this early, because we may - -- kill current values in Resolve_Call, and that call would - -- clobber the Last_Assignment field. - - -- Note: call Warn_On_Useless_Assignment before doing the check - -- below for Is_OK_Variable_For_Out_Formal so that the setting - -- of Referenced_As_LHS/Referenced_As_Out_Formal properly - -- reflects the last assignment, not this one! - - if Ekind (F) = E_Out_Parameter then - if Warn_On_Modified_As_Out_Parameter (F) - and then Is_Entity_Name (A) - and then Present (Entity (A)) - and then Comes_From_Source (N) - then - Warn_On_Useless_Assignment (Entity (A), A); - end if; - end if; - - -- Validate the form of the actual. Note that the call to - -- Is_OK_Variable_For_Out_Formal generates the required - -- reference in this case. - - if not Is_OK_Variable_For_Out_Formal (A) then - Error_Msg_NE ("actual for& must be a variable", A, F); - end if; - - -- What's the following about??? - - if Is_Entity_Name (A) then - Kill_Checks (Entity (A)); - else - Kill_All_Checks; - end if; - end if; - - if Etype (A) = Any_Type then - Set_Etype (N, Any_Type); - return; - end if; - - -- Apply appropriate range checks for in, out, and in-out - -- parameters. Out and in-out parameters also need a separate - -- check, if there is a type conversion, to make sure the return - -- value meets the constraints of the variable before the - -- conversion. - - -- Gigi looks at the check flag and uses the appropriate types. - -- For now since one flag is used there is an optimization which - -- might not be done in the In Out case since Gigi does not do - -- any analysis. More thought required about this ??? - - if Ekind (F) = E_In_Parameter - or else Ekind (F) = E_In_Out_Parameter - then - if Is_Scalar_Type (Etype (A)) then - Apply_Scalar_Range_Check (A, F_Typ); - - elsif Is_Array_Type (Etype (A)) then - Apply_Length_Check (A, F_Typ); - - elsif Is_Record_Type (F_Typ) - and then Has_Discriminants (F_Typ) - and then Is_Constrained (F_Typ) - and then (not Is_Derived_Type (F_Typ) - or else Comes_From_Source (Nam)) - then - Apply_Discriminant_Check (A, F_Typ); - - elsif Is_Access_Type (F_Typ) - and then Is_Array_Type (Designated_Type (F_Typ)) - and then Is_Constrained (Designated_Type (F_Typ)) - then - Apply_Length_Check (A, F_Typ); - - elsif Is_Access_Type (F_Typ) - and then Has_Discriminants (Designated_Type (F_Typ)) - and then Is_Constrained (Designated_Type (F_Typ)) - then - Apply_Discriminant_Check (A, F_Typ); - - else - Apply_Range_Check (A, F_Typ); - end if; - - -- Ada 2005 (AI-231) - - if Ada_Version >= Ada_05 - and then Is_Access_Type (F_Typ) - and then Can_Never_Be_Null (F_Typ) - and then Known_Null (A) - then - Apply_Compile_Time_Constraint_Error - (N => A, - Msg => "(Ada 2005) null not allowed in " - & "null-excluding formal?", - Reason => CE_Null_Not_Allowed); - end if; - end if; - - if Ekind (F) = E_Out_Parameter - or else Ekind (F) = E_In_Out_Parameter - then - if Nkind (A) = N_Type_Conversion then - if Is_Scalar_Type (A_Typ) then - Apply_Scalar_Range_Check - (Expression (A), Etype (Expression (A)), A_Typ); - else - Apply_Range_Check - (Expression (A), Etype (Expression (A)), A_Typ); - end if; - - else - if Is_Scalar_Type (F_Typ) then - Apply_Scalar_Range_Check (A, A_Typ, F_Typ); - - elsif Is_Array_Type (F_Typ) - and then Ekind (F) = E_Out_Parameter - then - Apply_Length_Check (A, F_Typ); - - else - Apply_Range_Check (A, A_Typ, F_Typ); - end if; - end if; - end if; - - -- An actual associated with an access parameter is implicitly - -- converted to the anonymous access type of the formal and must - -- satisfy the legality checks for access conversions. - - if Ekind (F_Typ) = E_Anonymous_Access_Type then - if not Valid_Conversion (A, F_Typ, A) then - Error_Msg_N - ("invalid implicit conversion for access parameter", A); - end if; - end if; - - -- Check bad case of atomic/volatile argument (RM C.6(12)) - - if Is_By_Reference_Type (Etype (F)) - and then Comes_From_Source (N) - then - if Is_Atomic_Object (A) - and then not Is_Atomic (Etype (F)) - then - Error_Msg_N - ("cannot pass atomic argument to non-atomic formal", - N); - - elsif Is_Volatile_Object (A) - and then not Is_Volatile (Etype (F)) - then - Error_Msg_N - ("cannot pass volatile argument to non-volatile formal", - N); - end if; - end if; - - -- Check that subprograms don't have improper controlling - -- arguments (RM 3.9.2 (9)) - - -- A primitive operation may have an access parameter of an - -- incomplete tagged type, but a dispatching call is illegal - -- if the type is still incomplete. - - if Is_Controlling_Formal (F) then - Set_Is_Controlling_Actual (A); - - if Ekind (Etype (F)) = E_Anonymous_Access_Type then - declare - Desig : constant Entity_Id := Designated_Type (Etype (F)); - begin - if Ekind (Desig) = E_Incomplete_Type - and then No (Full_View (Desig)) - and then No (Non_Limited_View (Desig)) - then - Error_Msg_NE - ("premature use of incomplete type& " & - "in dispatching call", A, Desig); - end if; - end; - end if; - - elsif Nkind (A) = N_Explicit_Dereference then - Validate_Remote_Access_To_Class_Wide_Type (A); - end if; - - if (Is_Class_Wide_Type (A_Typ) or else Is_Dynamically_Tagged (A)) - and then not Is_Class_Wide_Type (F_Typ) - and then not Is_Controlling_Formal (F) - then - Error_Msg_N ("class-wide argument not allowed here!", A); - - if Is_Subprogram (Nam) - and then Comes_From_Source (Nam) - then - Error_Msg_Node_2 := F_Typ; - Error_Msg_NE - ("& is not a dispatching operation of &!", A, Nam); - end if; - - elsif Is_Access_Type (A_Typ) - and then Is_Access_Type (F_Typ) - and then Ekind (F_Typ) /= E_Access_Subprogram_Type - and then Ekind (F_Typ) /= E_Anonymous_Access_Subprogram_Type - and then (Is_Class_Wide_Type (Designated_Type (A_Typ)) - or else (Nkind (A) = N_Attribute_Reference - and then - Is_Class_Wide_Type (Etype (Prefix (A))))) - and then not Is_Class_Wide_Type (Designated_Type (F_Typ)) - and then not Is_Controlling_Formal (F) - then - Error_Msg_N - ("access to class-wide argument not allowed here!", A); - - if Is_Subprogram (Nam) - and then Comes_From_Source (Nam) - then - Error_Msg_Node_2 := Designated_Type (F_Typ); - Error_Msg_NE - ("& is not a dispatching operation of &!", A, Nam); - end if; - end if; - - Eval_Actual (A); - - -- If it is a named association, treat the selector_name as - -- a proper identifier, and mark the corresponding entity. - - if Nkind (Parent (A)) = N_Parameter_Association then - Set_Entity (Selector_Name (Parent (A)), F); - Generate_Reference (F, Selector_Name (Parent (A))); - Set_Etype (Selector_Name (Parent (A)), F_Typ); - Generate_Reference (F_Typ, N, ' '); - end if; - - Prev := A; - - if Ekind (F) /= E_Out_Parameter then - Check_Unset_Reference (A); - end if; - - Next_Actual (A); - - -- Case where actual is not present - - else - Insert_Default; - end if; - - Next_Formal (F); - end loop; - end Resolve_Actuals; - - ----------------------- - -- Resolve_Allocator -- - ----------------------- - - procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id) is - E : constant Node_Id := Expression (N); - Subtyp : Entity_Id; - Discrim : Entity_Id; - Constr : Node_Id; - Aggr : Node_Id; - Assoc : Node_Id := Empty; - Disc_Exp : Node_Id; - - procedure Check_Allocator_Discrim_Accessibility - (Disc_Exp : Node_Id; - Alloc_Typ : Entity_Id); - -- Check that accessibility level associated with an access discriminant - -- initialized in an allocator by the expression Disc_Exp is not deeper - -- than the level of the allocator type Alloc_Typ. An error message is - -- issued if this condition is violated. Specialized checks are done for - -- the cases of a constraint expression which is an access attribute or - -- an access discriminant. - - function In_Dispatching_Context return Boolean; - -- If the allocator is an actual in a call, it is allowed to be class- - -- wide when the context is not because it is a controlling actual. - - procedure Propagate_Coextensions (Root : Node_Id); - -- Propagate all nested coextensions which are located one nesting - -- level down the tree to the node Root. Example: - -- - -- Top_Record - -- Level_1_Coextension - -- Level_2_Coextension - -- - -- The algorithm is paired with delay actions done by the Expander. In - -- the above example, assume all coextensions are controlled types. - -- The cycle of analysis, resolution and expansion will yield: - -- - -- 1) Analyze Top_Record - -- 2) Analyze Level_1_Coextension - -- 3) Analyze Level_2_Coextension - -- 4) Resolve Level_2_Coextension. The allocator is marked as a - -- coextension. - -- 5) Expand Level_2_Coextension. A temporary variable Temp_1 is - -- generated to capture the allocated object. Temp_1 is attached - -- to the coextension chain of Level_2_Coextension. - -- 6) Resolve Level_1_Coextension. The allocator is marked as a - -- coextension. A forward tree traversal is performed which finds - -- Level_2_Coextension's list and copies its contents into its - -- own list. - -- 7) Expand Level_1_Coextension. A temporary variable Temp_2 is - -- generated to capture the allocated object. Temp_2 is attached - -- to the coextension chain of Level_1_Coextension. Currently, the - -- contents of the list are [Temp_2, Temp_1]. - -- 8) Resolve Top_Record. A forward tree traversal is performed which - -- finds Level_1_Coextension's list and copies its contents into - -- its own list. - -- 9) Expand Top_Record. Generate finalization calls for Temp_1 and - -- Temp_2 and attach them to Top_Record's finalization list. - - ------------------------------------------- - -- Check_Allocator_Discrim_Accessibility -- - ------------------------------------------- - - procedure Check_Allocator_Discrim_Accessibility - (Disc_Exp : Node_Id; - Alloc_Typ : Entity_Id) - is - begin - if Type_Access_Level (Etype (Disc_Exp)) > - Type_Access_Level (Alloc_Typ) - then - Error_Msg_N - ("operand type has deeper level than allocator type", Disc_Exp); - - -- When the expression is an Access attribute the level of the prefix - -- object must not be deeper than that of the allocator's type. - - elsif Nkind (Disc_Exp) = N_Attribute_Reference - and then Get_Attribute_Id (Attribute_Name (Disc_Exp)) - = Attribute_Access - and then Object_Access_Level (Prefix (Disc_Exp)) - > Type_Access_Level (Alloc_Typ) - then - Error_Msg_N - ("prefix of attribute has deeper level than allocator type", - Disc_Exp); - - -- When the expression is an access discriminant the check is against - -- the level of the prefix object. - - elsif Ekind (Etype (Disc_Exp)) = E_Anonymous_Access_Type - and then Nkind (Disc_Exp) = N_Selected_Component - and then Object_Access_Level (Prefix (Disc_Exp)) - > Type_Access_Level (Alloc_Typ) - then - Error_Msg_N - ("access discriminant has deeper level than allocator type", - Disc_Exp); - - -- All other cases are legal - - else - null; - end if; - end Check_Allocator_Discrim_Accessibility; - - ---------------------------- - -- In_Dispatching_Context -- - ---------------------------- - - function In_Dispatching_Context return Boolean is - Par : constant Node_Id := Parent (N); - begin - return Nkind_In (Par, N_Function_Call, N_Procedure_Call_Statement) - and then Is_Entity_Name (Name (Par)) - and then Is_Dispatching_Operation (Entity (Name (Par))); - end In_Dispatching_Context; - - ---------------------------- - -- Propagate_Coextensions -- - ---------------------------- - - procedure Propagate_Coextensions (Root : Node_Id) is - - procedure Copy_List (From : Elist_Id; To : Elist_Id); - -- Copy the contents of list From into list To, preserving the - -- order of elements. - - function Process_Allocator (Nod : Node_Id) return Traverse_Result; - -- Recognize an allocator or a rewritten allocator node and add it - -- along with its nested coextensions to the list of Root. - - --------------- - -- Copy_List -- - --------------- - - procedure Copy_List (From : Elist_Id; To : Elist_Id) is - From_Elmt : Elmt_Id; - begin - From_Elmt := First_Elmt (From); - while Present (From_Elmt) loop - Append_Elmt (Node (From_Elmt), To); - Next_Elmt (From_Elmt); - end loop; - end Copy_List; - - ----------------------- - -- Process_Allocator -- - ----------------------- - - function Process_Allocator (Nod : Node_Id) return Traverse_Result is - Orig_Nod : Node_Id := Nod; - - begin - -- This is a possible rewritten subtype indication allocator. Any - -- nested coextensions will appear as discriminant constraints. - - if Nkind (Nod) = N_Identifier - and then Present (Original_Node (Nod)) - and then Nkind (Original_Node (Nod)) = N_Subtype_Indication - then - declare - Discr : Node_Id; - Discr_Elmt : Elmt_Id; - - begin - if Is_Record_Type (Entity (Nod)) then - Discr_Elmt := - First_Elmt (Discriminant_Constraint (Entity (Nod))); - while Present (Discr_Elmt) loop - Discr := Node (Discr_Elmt); - - if Nkind (Discr) = N_Identifier - and then Present (Original_Node (Discr)) - and then Nkind (Original_Node (Discr)) = N_Allocator - and then Present (Coextensions ( - Original_Node (Discr))) - then - if No (Coextensions (Root)) then - Set_Coextensions (Root, New_Elmt_List); - end if; - - Copy_List - (From => Coextensions (Original_Node (Discr)), - To => Coextensions (Root)); - end if; - - Next_Elmt (Discr_Elmt); - end loop; - - -- There is no need to continue the traversal of this - -- subtree since all the information has already been - -- propagated. - - return Skip; - end if; - end; - - -- Case of either a stand alone allocator or a rewritten allocator - -- with an aggregate. - - else - if Present (Original_Node (Nod)) then - Orig_Nod := Original_Node (Nod); - end if; - - if Nkind (Orig_Nod) = N_Allocator then - - -- Propagate the list of nested coextensions to the Root - -- allocator. This is done through list copy since a single - -- allocator may have multiple coextensions. Do not touch - -- coextensions roots. - - if not Is_Coextension_Root (Orig_Nod) - and then Present (Coextensions (Orig_Nod)) - then - if No (Coextensions (Root)) then - Set_Coextensions (Root, New_Elmt_List); - end if; - - Copy_List - (From => Coextensions (Orig_Nod), - To => Coextensions (Root)); - end if; - - -- There is no need to continue the traversal of this - -- subtree since all the information has already been - -- propagated. - - return Skip; - end if; - end if; - - -- Keep on traversing, looking for the next allocator - - return OK; - end Process_Allocator; - - procedure Process_Allocators is - new Traverse_Proc (Process_Allocator); - - -- Start of processing for Propagate_Coextensions - - begin - Process_Allocators (Expression (Root)); - end Propagate_Coextensions; - - -- Start of processing for Resolve_Allocator - - begin - -- Replace general access with specific type - - if Ekind (Etype (N)) = E_Allocator_Type then - Set_Etype (N, Base_Type (Typ)); - end if; - - if Is_Abstract_Type (Typ) then - Error_Msg_N ("type of allocator cannot be abstract", N); - end if; - - -- For qualified expression, resolve the expression using the - -- given subtype (nothing to do for type mark, subtype indication) - - if Nkind (E) = N_Qualified_Expression then - if Is_Class_Wide_Type (Etype (E)) - and then not Is_Class_Wide_Type (Designated_Type (Typ)) - and then not In_Dispatching_Context - then - Error_Msg_N - ("class-wide allocator not allowed for this access type", N); - end if; - - Resolve (Expression (E), Etype (E)); - Check_Unset_Reference (Expression (E)); - - -- A qualified expression requires an exact match of the type, - -- class-wide matching is not allowed. - - if (Is_Class_Wide_Type (Etype (Expression (E))) - or else Is_Class_Wide_Type (Etype (E))) - and then Base_Type (Etype (Expression (E))) /= Base_Type (Etype (E)) - then - Wrong_Type (Expression (E), Etype (E)); - end if; - - -- A special accessibility check is needed for allocators that - -- constrain access discriminants. The level of the type of the - -- expression used to constrain an access discriminant cannot be - -- deeper than the type of the allocator (in contrast to access - -- parameters, where the level of the actual can be arbitrary). - - -- We can't use Valid_Conversion to perform this check because - -- in general the type of the allocator is unrelated to the type - -- of the access discriminant. - - if Ekind (Typ) /= E_Anonymous_Access_Type - or else Is_Local_Anonymous_Access (Typ) - then - Subtyp := Entity (Subtype_Mark (E)); - - Aggr := Original_Node (Expression (E)); - - if Has_Discriminants (Subtyp) - and then Nkind_In (Aggr, N_Aggregate, N_Extension_Aggregate) - then - Discrim := First_Discriminant (Base_Type (Subtyp)); - - -- Get the first component expression of the aggregate - - if Present (Expressions (Aggr)) then - Disc_Exp := First (Expressions (Aggr)); - - elsif Present (Component_Associations (Aggr)) then - Assoc := First (Component_Associations (Aggr)); - - if Present (Assoc) then - Disc_Exp := Expression (Assoc); - else - Disc_Exp := Empty; - end if; - - else - Disc_Exp := Empty; - end if; - - while Present (Discrim) and then Present (Disc_Exp) loop - if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then - Check_Allocator_Discrim_Accessibility (Disc_Exp, Typ); - end if; - - Next_Discriminant (Discrim); - - if Present (Discrim) then - if Present (Assoc) then - Next (Assoc); - Disc_Exp := Expression (Assoc); - - elsif Present (Next (Disc_Exp)) then - Next (Disc_Exp); - - else - Assoc := First (Component_Associations (Aggr)); - - if Present (Assoc) then - Disc_Exp := Expression (Assoc); - else - Disc_Exp := Empty; - end if; - end if; - end if; - end loop; - end if; - end if; - - -- For a subtype mark or subtype indication, freeze the subtype - - else - Freeze_Expression (E); - - if Is_Access_Constant (Typ) and then not No_Initialization (N) then - Error_Msg_N - ("initialization required for access-to-constant allocator", N); - end if; - - -- A special accessibility check is needed for allocators that - -- constrain access discriminants. The level of the type of the - -- expression used to constrain an access discriminant cannot be - -- deeper than the type of the allocator (in contrast to access - -- parameters, where the level of the actual can be arbitrary). - -- We can't use Valid_Conversion to perform this check because - -- in general the type of the allocator is unrelated to the type - -- of the access discriminant. - - if Nkind (Original_Node (E)) = N_Subtype_Indication - and then (Ekind (Typ) /= E_Anonymous_Access_Type - or else Is_Local_Anonymous_Access (Typ)) - then - Subtyp := Entity (Subtype_Mark (Original_Node (E))); - - if Has_Discriminants (Subtyp) then - Discrim := First_Discriminant (Base_Type (Subtyp)); - Constr := First (Constraints (Constraint (Original_Node (E)))); - while Present (Discrim) and then Present (Constr) loop - if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then - if Nkind (Constr) = N_Discriminant_Association then - Disc_Exp := Original_Node (Expression (Constr)); - else - Disc_Exp := Original_Node (Constr); - end if; - - Check_Allocator_Discrim_Accessibility (Disc_Exp, Typ); - end if; - - Next_Discriminant (Discrim); - Next (Constr); - end loop; - end if; - end if; - end if; - - -- Ada 2005 (AI-344): A class-wide allocator requires an accessibility - -- check that the level of the type of the created object is not deeper - -- than the level of the allocator's access type, since extensions can - -- now occur at deeper levels than their ancestor types. This is a - -- static accessibility level check; a run-time check is also needed in - -- the case of an initialized allocator with a class-wide argument (see - -- Expand_Allocator_Expression). - - if Ada_Version >= Ada_05 - and then Is_Class_Wide_Type (Designated_Type (Typ)) - then - declare - Exp_Typ : Entity_Id; - - begin - if Nkind (E) = N_Qualified_Expression then - Exp_Typ := Etype (E); - elsif Nkind (E) = N_Subtype_Indication then - Exp_Typ := Entity (Subtype_Mark (Original_Node (E))); - else - Exp_Typ := Entity (E); - end if; - - if Type_Access_Level (Exp_Typ) > Type_Access_Level (Typ) then - if In_Instance_Body then - Error_Msg_N ("?type in allocator has deeper level than" & - " designated class-wide type", E); - Error_Msg_N ("\?Program_Error will be raised at run time", - E); - Rewrite (N, - Make_Raise_Program_Error (Sloc (N), - Reason => PE_Accessibility_Check_Failed)); - Set_Etype (N, Typ); - - -- Do not apply Ada 2005 accessibility checks on a class-wide - -- allocator if the type given in the allocator is a formal - -- type. A run-time check will be performed in the instance. - - elsif not Is_Generic_Type (Exp_Typ) then - Error_Msg_N ("type in allocator has deeper level than" & - " designated class-wide type", E); - end if; - end if; - end; - end if; - - -- Check for allocation from an empty storage pool - - if No_Pool_Assigned (Typ) then - declare - Loc : constant Source_Ptr := Sloc (N); - begin - Error_Msg_N ("?allocation from empty storage pool!", N); - Error_Msg_N ("\?Storage_Error will be raised at run time!", N); - Insert_Action (N, - Make_Raise_Storage_Error (Loc, - Reason => SE_Empty_Storage_Pool)); - end; - - -- If the context is an unchecked conversion, as may happen within - -- an inlined subprogram, the allocator is being resolved with its - -- own anonymous type. In that case, if the target type has a specific - -- storage pool, it must be inherited explicitly by the allocator type. - - elsif Nkind (Parent (N)) = N_Unchecked_Type_Conversion - and then No (Associated_Storage_Pool (Typ)) - then - Set_Associated_Storage_Pool - (Typ, Associated_Storage_Pool (Etype (Parent (N)))); - end if; - - -- An erroneous allocator may be rewritten as a raise Program_Error - -- statement. - - if Nkind (N) = N_Allocator then - - -- An anonymous access discriminant is the definition of a - -- coextension. - - if Ekind (Typ) = E_Anonymous_Access_Type - and then Nkind (Associated_Node_For_Itype (Typ)) = - N_Discriminant_Specification - then - -- Avoid marking an allocator as a dynamic coextension if it is - -- within a static construct. - - if not Is_Static_Coextension (N) then - Set_Is_Dynamic_Coextension (N); - end if; - - -- Cleanup for potential static coextensions - - else - Set_Is_Dynamic_Coextension (N, False); - Set_Is_Static_Coextension (N, False); - end if; - - -- There is no need to propagate any nested coextensions if they - -- are marked as static since they will be rewritten on the spot. - - if not Is_Static_Coextension (N) then - Propagate_Coextensions (N); - end if; - end if; - end Resolve_Allocator; - - --------------------------- - -- Resolve_Arithmetic_Op -- - --------------------------- - - -- Used for resolving all arithmetic operators except exponentiation - - procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id) is - L : constant Node_Id := Left_Opnd (N); - R : constant Node_Id := Right_Opnd (N); - TL : constant Entity_Id := Base_Type (Etype (L)); - TR : constant Entity_Id := Base_Type (Etype (R)); - T : Entity_Id; - Rop : Node_Id; - - B_Typ : constant Entity_Id := Base_Type (Typ); - -- We do the resolution using the base type, because intermediate values - -- in expressions always are of the base type, not a subtype of it. - - function Expected_Type_Is_Any_Real (N : Node_Id) return Boolean; - -- Returns True if N is in a context that expects "any real type" - - function Is_Integer_Or_Universal (N : Node_Id) return Boolean; - -- Return True iff given type is Integer or universal real/integer - - procedure Set_Mixed_Mode_Operand (N : Node_Id; T : Entity_Id); - -- Choose type of integer literal in fixed-point operation to conform - -- to available fixed-point type. T is the type of the other operand, - -- which is needed to determine the expected type of N. - - procedure Set_Operand_Type (N : Node_Id); - -- Set operand type to T if universal - - ------------------------------- - -- Expected_Type_Is_Any_Real -- - ------------------------------- - - function Expected_Type_Is_Any_Real (N : Node_Id) return Boolean is - begin - -- N is the expression after "delta" in a fixed_point_definition; - -- see RM-3.5.9(6): - - return Nkind_In (Parent (N), N_Ordinary_Fixed_Point_Definition, - N_Decimal_Fixed_Point_Definition, - - -- N is one of the bounds in a real_range_specification; - -- see RM-3.5.7(5): - - N_Real_Range_Specification, - - -- N is the expression of a delta_constraint; - -- see RM-J.3(3): - - N_Delta_Constraint); - end Expected_Type_Is_Any_Real; - - ----------------------------- - -- Is_Integer_Or_Universal -- - ----------------------------- - - function Is_Integer_Or_Universal (N : Node_Id) return Boolean is - T : Entity_Id; - Index : Interp_Index; - It : Interp; - - begin - if not Is_Overloaded (N) then - T := Etype (N); - return Base_Type (T) = Base_Type (Standard_Integer) - or else T = Universal_Integer - or else T = Universal_Real; - else - Get_First_Interp (N, Index, It); - while Present (It.Typ) loop - if Base_Type (It.Typ) = Base_Type (Standard_Integer) - or else It.Typ = Universal_Integer - or else It.Typ = Universal_Real - then - return True; - end if; - - Get_Next_Interp (Index, It); - end loop; - end if; - - return False; - end Is_Integer_Or_Universal; - - ---------------------------- - -- Set_Mixed_Mode_Operand -- - ---------------------------- - - procedure Set_Mixed_Mode_Operand (N : Node_Id; T : Entity_Id) is - Index : Interp_Index; - It : Interp; - - begin - if Universal_Interpretation (N) = Universal_Integer then - - -- A universal integer literal is resolved as standard integer - -- except in the case of a fixed-point result, where we leave it - -- as universal (to be handled by Exp_Fixd later on) - - if Is_Fixed_Point_Type (T) then - Resolve (N, Universal_Integer); - else - Resolve (N, Standard_Integer); - end if; - - elsif Universal_Interpretation (N) = Universal_Real - and then (T = Base_Type (Standard_Integer) - or else T = Universal_Integer - or else T = Universal_Real) - then - -- A universal real can appear in a fixed-type context. We resolve - -- the literal with that context, even though this might raise an - -- exception prematurely (the other operand may be zero). - - Resolve (N, B_Typ); - - elsif Etype (N) = Base_Type (Standard_Integer) - and then T = Universal_Real - and then Is_Overloaded (N) - then - -- Integer arg in mixed-mode operation. Resolve with universal - -- type, in case preference rule must be applied. - - Resolve (N, Universal_Integer); - - elsif Etype (N) = T - and then B_Typ /= Universal_Fixed - then - -- Not a mixed-mode operation, resolve with context - - Resolve (N, B_Typ); - - elsif Etype (N) = Any_Fixed then - - -- N may itself be a mixed-mode operation, so use context type - - Resolve (N, B_Typ); - - elsif Is_Fixed_Point_Type (T) - and then B_Typ = Universal_Fixed - and then Is_Overloaded (N) - then - -- Must be (fixed * fixed) operation, operand must have one - -- compatible interpretation. - - Resolve (N, Any_Fixed); - - elsif Is_Fixed_Point_Type (B_Typ) - and then (T = Universal_Real - or else Is_Fixed_Point_Type (T)) - and then Is_Overloaded (N) - then - -- C * F(X) in a fixed context, where C is a real literal or a - -- fixed-point expression. F must have either a fixed type - -- interpretation or an integer interpretation, but not both. - - Get_First_Interp (N, Index, It); - while Present (It.Typ) loop - if Base_Type (It.Typ) = Base_Type (Standard_Integer) then - - if Analyzed (N) then - Error_Msg_N ("ambiguous operand in fixed operation", N); - else - Resolve (N, Standard_Integer); - end if; - - elsif Is_Fixed_Point_Type (It.Typ) then - - if Analyzed (N) then - Error_Msg_N ("ambiguous operand in fixed operation", N); - else - Resolve (N, It.Typ); - end if; - end if; - - Get_Next_Interp (Index, It); - end loop; - - -- Reanalyze the literal with the fixed type of the context. If - -- context is Universal_Fixed, we are within a conversion, leave - -- the literal as a universal real because there is no usable - -- fixed type, and the target of the conversion plays no role in - -- the resolution. - - declare - Op2 : Node_Id; - T2 : Entity_Id; - - begin - if N = L then - Op2 := R; - else - Op2 := L; - end if; - - if B_Typ = Universal_Fixed - and then Nkind (Op2) = N_Real_Literal - then - T2 := Universal_Real; - else - T2 := B_Typ; - end if; - - Set_Analyzed (Op2, False); - Resolve (Op2, T2); - end; - - else - Resolve (N); - end if; - end Set_Mixed_Mode_Operand; - - ---------------------- - -- Set_Operand_Type -- - ---------------------- - - procedure Set_Operand_Type (N : Node_Id) is - begin - if Etype (N) = Universal_Integer - or else Etype (N) = Universal_Real - then - Set_Etype (N, T); - end if; - end Set_Operand_Type; - - -- Start of processing for Resolve_Arithmetic_Op - - begin - if Comes_From_Source (N) - and then Ekind (Entity (N)) = E_Function - and then Is_Imported (Entity (N)) - and then Is_Intrinsic_Subprogram (Entity (N)) - then - Resolve_Intrinsic_Operator (N, Typ); - return; - - -- Special-case for mixed-mode universal expressions or fixed point - -- type operation: each argument is resolved separately. The same - -- treatment is required if one of the operands of a fixed point - -- operation is universal real, since in this case we don't do a - -- conversion to a specific fixed-point type (instead the expander - -- takes care of the case). - - elsif (B_Typ = Universal_Integer or else B_Typ = Universal_Real) - and then Present (Universal_Interpretation (L)) - and then Present (Universal_Interpretation (R)) - then - Resolve (L, Universal_Interpretation (L)); - Resolve (R, Universal_Interpretation (R)); - Set_Etype (N, B_Typ); - - elsif (B_Typ = Universal_Real - or else Etype (N) = Universal_Fixed - or else (Etype (N) = Any_Fixed - and then Is_Fixed_Point_Type (B_Typ)) - or else (Is_Fixed_Point_Type (B_Typ) - and then (Is_Integer_Or_Universal (L) - or else - Is_Integer_Or_Universal (R)))) - and then Nkind_In (N, N_Op_Multiply, N_Op_Divide) - then - if TL = Universal_Integer or else TR = Universal_Integer then - Check_For_Visible_Operator (N, B_Typ); - end if; - - -- If context is a fixed type and one operand is integer, the - -- other is resolved with the type of the context. - - if Is_Fixed_Point_Type (B_Typ) - and then (Base_Type (TL) = Base_Type (Standard_Integer) - or else TL = Universal_Integer) - then - Resolve (R, B_Typ); - Resolve (L, TL); - - elsif Is_Fixed_Point_Type (B_Typ) - and then (Base_Type (TR) = Base_Type (Standard_Integer) - or else TR = Universal_Integer) - then - Resolve (L, B_Typ); - Resolve (R, TR); - - else - Set_Mixed_Mode_Operand (L, TR); - Set_Mixed_Mode_Operand (R, TL); - end if; - - -- Check the rule in RM05-4.5.5(19.1/2) disallowing universal_fixed - -- multiplying operators from being used when the expected type is - -- also universal_fixed. Note that B_Typ will be Universal_Fixed in - -- some cases where the expected type is actually Any_Real; - -- Expected_Type_Is_Any_Real takes care of that case. - - if Etype (N) = Universal_Fixed - or else Etype (N) = Any_Fixed - then - if B_Typ = Universal_Fixed - and then not Expected_Type_Is_Any_Real (N) - and then not Nkind_In (Parent (N), N_Type_Conversion, - N_Unchecked_Type_Conversion) - then - Error_Msg_N ("type cannot be determined from context!", N); - Error_Msg_N ("\explicit conversion to result type required", N); - - Set_Etype (L, Any_Type); - Set_Etype (R, Any_Type); - - else - if Ada_Version = Ada_83 - and then Etype (N) = Universal_Fixed - and then not - Nkind_In (Parent (N), N_Type_Conversion, - N_Unchecked_Type_Conversion) - then - Error_Msg_N - ("(Ada 83) fixed-point operation " - & "needs explicit conversion", N); - end if; - - -- The expected type is "any real type" in contexts like - -- type T is delta <universal_fixed-expression> ... - -- in which case we need to set the type to Universal_Real - -- so that static expression evaluation will work properly. - - if Expected_Type_Is_Any_Real (N) then - Set_Etype (N, Universal_Real); - else - Set_Etype (N, B_Typ); - end if; - end if; - - elsif Is_Fixed_Point_Type (B_Typ) - and then (Is_Integer_Or_Universal (L) - or else Nkind (L) = N_Real_Literal - or else Nkind (R) = N_Real_Literal - or else Is_Integer_Or_Universal (R)) - then - Set_Etype (N, B_Typ); - - elsif Etype (N) = Any_Fixed then - - -- If no previous errors, this is only possible if one operand - -- is overloaded and the context is universal. Resolve as such. - - Set_Etype (N, B_Typ); - end if; - - else - if (TL = Universal_Integer or else TL = Universal_Real) - and then - (TR = Universal_Integer or else TR = Universal_Real) - then - Check_For_Visible_Operator (N, B_Typ); - end if; - - -- If the context is Universal_Fixed and the operands are also - -- universal fixed, this is an error, unless there is only one - -- applicable fixed_point type (usually duration). - - if B_Typ = Universal_Fixed and then Etype (L) = Universal_Fixed then - T := Unique_Fixed_Point_Type (N); - - if T = Any_Type then - Set_Etype (N, T); - return; - else - Resolve (L, T); - Resolve (R, T); - end if; - - else - Resolve (L, B_Typ); - Resolve (R, B_Typ); - end if; - - -- If one of the arguments was resolved to a non-universal type. - -- label the result of the operation itself with the same type. - -- Do the same for the universal argument, if any. - - T := Intersect_Types (L, R); - Set_Etype (N, Base_Type (T)); - Set_Operand_Type (L); - Set_Operand_Type (R); - end if; - - Generate_Operator_Reference (N, Typ); - Eval_Arithmetic_Op (N); - - -- Set overflow and division checking bit. Much cleverer code needed - -- here eventually and perhaps the Resolve routines should be separated - -- for the various arithmetic operations, since they will need - -- different processing. ??? - - if Nkind (N) in N_Op then - if not Overflow_Checks_Suppressed (Etype (N)) then - Enable_Overflow_Check (N); - end if; - - -- Give warning if explicit division by zero - - if Nkind_In (N, N_Op_Divide, N_Op_Rem, N_Op_Mod) - and then not Division_Checks_Suppressed (Etype (N)) - then - Rop := Right_Opnd (N); - - if Compile_Time_Known_Value (Rop) - and then ((Is_Integer_Type (Etype (Rop)) - and then Expr_Value (Rop) = Uint_0) - or else - (Is_Real_Type (Etype (Rop)) - and then Expr_Value_R (Rop) = Ureal_0)) - then - -- Specialize the warning message according to the operation - - case Nkind (N) is - when N_Op_Divide => - Apply_Compile_Time_Constraint_Error - (N, "division by zero?", CE_Divide_By_Zero, - Loc => Sloc (Right_Opnd (N))); - - when N_Op_Rem => - Apply_Compile_Time_Constraint_Error - (N, "rem with zero divisor?", CE_Divide_By_Zero, - Loc => Sloc (Right_Opnd (N))); - - when N_Op_Mod => - Apply_Compile_Time_Constraint_Error - (N, "mod with zero divisor?", CE_Divide_By_Zero, - Loc => Sloc (Right_Opnd (N))); - - -- Division by zero can only happen with division, rem, - -- and mod operations. - - when others => - raise Program_Error; - end case; - - -- Otherwise just set the flag to check at run time - - else - Activate_Division_Check (N); - end if; - end if; - - -- If Restriction No_Implicit_Conditionals is active, then it is - -- violated if either operand can be negative for mod, or for rem - -- if both operands can be negative. - - if Restrictions.Set (No_Implicit_Conditionals) - and then Nkind_In (N, N_Op_Rem, N_Op_Mod) - then - declare - Lo : Uint; - Hi : Uint; - OK : Boolean; - - LNeg : Boolean; - RNeg : Boolean; - -- Set if corresponding operand might be negative - - begin - Determine_Range (Left_Opnd (N), OK, Lo, Hi); - LNeg := (not OK) or else Lo < 0; - - Determine_Range (Right_Opnd (N), OK, Lo, Hi); - RNeg := (not OK) or else Lo < 0; - - if (Nkind (N) = N_Op_Rem and then (LNeg and RNeg)) - or else - (Nkind (N) = N_Op_Mod and then (LNeg or RNeg)) - then - Check_Restriction (No_Implicit_Conditionals, N); - end if; - end; - end if; - end if; - - Check_Unset_Reference (L); - Check_Unset_Reference (R); - end Resolve_Arithmetic_Op; - - ------------------ - -- Resolve_Call -- - ------------------ - - procedure Resolve_Call (N : Node_Id; Typ : Entity_Id) is - Loc : constant Source_Ptr := Sloc (N); - Subp : constant Node_Id := Name (N); - Nam : Entity_Id; - I : Interp_Index; - It : Interp; - Norm_OK : Boolean; - Scop : Entity_Id; - Rtype : Entity_Id; - - begin - -- The context imposes a unique interpretation with type Typ on a - -- procedure or function call. Find the entity of the subprogram that - -- yields the expected type, and propagate the corresponding formal - -- constraints on the actuals. The caller has established that an - -- interpretation exists, and emitted an error if not unique. - - -- First deal with the case of a call to an access-to-subprogram, - -- dereference made explicit in Analyze_Call. - - if Ekind (Etype (Subp)) = E_Subprogram_Type then - if not Is_Overloaded (Subp) then - Nam := Etype (Subp); - - else - -- Find the interpretation whose type (a subprogram type) has a - -- return type that is compatible with the context. Analysis of - -- the node has established that one exists. - - Nam := Empty; - - Get_First_Interp (Subp, I, It); - while Present (It.Typ) loop - if Covers (Typ, Etype (It.Typ)) then - Nam := It.Typ; - exit; - end if; - - Get_Next_Interp (I, It); - end loop; - - if No (Nam) then - raise Program_Error; - end if; - end if; - - -- If the prefix is not an entity, then resolve it - - if not Is_Entity_Name (Subp) then - Resolve (Subp, Nam); - end if; - - -- For an indirect call, we always invalidate checks, since we do not - -- know whether the subprogram is local or global. Yes we could do - -- better here, e.g. by knowing that there are no local subprograms, - -- but it does not seem worth the effort. Similarly, we kill all - -- knowledge of current constant values. - - Kill_Current_Values; - - -- If this is a procedure call which is really an entry call, do - -- the conversion of the procedure call to an entry call. Protected - -- operations use the same circuitry because the name in the call - -- can be an arbitrary expression with special resolution rules. - - elsif Nkind_In (Subp, N_Selected_Component, N_Indexed_Component) - or else (Is_Entity_Name (Subp) - and then Ekind (Entity (Subp)) = E_Entry) - then - Resolve_Entry_Call (N, Typ); - Check_Elab_Call (N); - - -- Kill checks and constant values, as above for indirect case - -- Who knows what happens when another task is activated? - - Kill_Current_Values; - return; - - -- Normal subprogram call with name established in Resolve - - elsif not (Is_Type (Entity (Subp))) then - Nam := Entity (Subp); - Set_Entity_With_Style_Check (Subp, Nam); - - -- Otherwise we must have the case of an overloaded call - - else - pragma Assert (Is_Overloaded (Subp)); - Nam := Empty; -- We know that it will be assigned in loop below - - Get_First_Interp (Subp, I, It); - while Present (It.Typ) loop - if Covers (Typ, It.Typ) then - Nam := It.Nam; - Set_Entity_With_Style_Check (Subp, Nam); - exit; - end if; - - Get_Next_Interp (I, It); - end loop; - end if; - - if Is_Access_Subprogram_Type (Base_Type (Etype (Nam))) - and then not Is_Access_Subprogram_Type (Base_Type (Typ)) - and then Nkind (Subp) /= N_Explicit_Dereference - and then Present (Parameter_Associations (N)) - then - -- The prefix is a parameterless function call that returns an access - -- to subprogram. If parameters are present in the current call, add - -- add an explicit dereference. We use the base type here because - -- within an instance these may be subtypes. - - -- The dereference is added either in Analyze_Call or here. Should - -- be consolidated ??? - - Set_Is_Overloaded (Subp, False); - Set_Etype (Subp, Etype (Nam)); - Insert_Explicit_Dereference (Subp); - Nam := Designated_Type (Etype (Nam)); - Resolve (Subp, Nam); - end if; - - -- Check that a call to Current_Task does not occur in an entry body - - if Is_RTE (Nam, RE_Current_Task) then - declare - P : Node_Id; - - begin - P := N; - loop - P := Parent (P); - - -- Exclude calls that occur within the default of a formal - -- parameter of the entry, since those are evaluated outside - -- of the body. - - exit when No (P) or else Nkind (P) = N_Parameter_Specification; - - if Nkind (P) = N_Entry_Body - or else (Nkind (P) = N_Subprogram_Body - and then Is_Entry_Barrier_Function (P)) - then - Rtype := Etype (N); - Error_Msg_NE - ("?& should not be used in entry body (RM C.7(17))", - N, Nam); - Error_Msg_NE - ("\Program_Error will be raised at run time?", N, Nam); - Rewrite (N, - Make_Raise_Program_Error (Loc, - Reason => PE_Current_Task_In_Entry_Body)); - Set_Etype (N, Rtype); - return; - end if; - end loop; - end; - end if; - - -- Check that a procedure call does not occur in the context of the - -- entry call statement of a conditional or timed entry call. Note that - -- the case of a call to a subprogram renaming of an entry will also be - -- rejected. The test for N not being an N_Entry_Call_Statement is - -- defensive, covering the possibility that the processing of entry - -- calls might reach this point due to later modifications of the code - -- above. - - if Nkind (Parent (N)) = N_Entry_Call_Alternative - and then Nkind (N) /= N_Entry_Call_Statement - and then Entry_Call_Statement (Parent (N)) = N - then - if Ada_Version < Ada_05 then - Error_Msg_N ("entry call required in select statement", N); - - -- Ada 2005 (AI-345): If a procedure_call_statement is used - -- for a procedure_or_entry_call, the procedure_name or - -- procedure_prefix of the procedure_call_statement shall denote - -- an entry renamed by a procedure, or (a view of) a primitive - -- subprogram of a limited interface whose first parameter is - -- a controlling parameter. - - elsif Nkind (N) = N_Procedure_Call_Statement - and then not Is_Renamed_Entry (Nam) - and then not Is_Controlling_Limited_Procedure (Nam) - then - Error_Msg_N - ("entry call or dispatching primitive of interface required", N); - end if; - end if; - - -- Check that this is not a call to a protected procedure or entry from - -- within a protected function. - - if Ekind (Current_Scope) = E_Function - and then Ekind (Scope (Current_Scope)) = E_Protected_Type - and then Ekind (Nam) /= E_Function - and then Scope (Nam) = Scope (Current_Scope) - then - Error_Msg_N ("within protected function, protected " & - "object is constant", N); - Error_Msg_N ("\cannot call operation that may modify it", N); - end if; - - -- Freeze the subprogram name if not in a spec-expression. Note that we - -- freeze procedure calls as well as function calls. Procedure calls are - -- not frozen according to the rules (RM 13.14(14)) because it is - -- impossible to have a procedure call to a non-frozen procedure in pure - -- Ada, but in the code that we generate in the expander, this rule - -- needs extending because we can generate procedure calls that need - -- freezing. - - if Is_Entity_Name (Subp) and then not In_Spec_Expression then - Freeze_Expression (Subp); - end if; - - -- For a predefined operator, the type of the result is the type imposed - -- by context, except for a predefined operation on universal fixed. - -- Otherwise The type of the call is the type returned by the subprogram - -- being called. - - if Is_Predefined_Op (Nam) then - if Etype (N) /= Universal_Fixed then - Set_Etype (N, Typ); - end if; - - -- If the subprogram returns an array type, and the context requires the - -- component type of that array type, the node is really an indexing of - -- the parameterless call. Resolve as such. A pathological case occurs - -- when the type of the component is an access to the array type. In - -- this case the call is truly ambiguous. - - elsif (Needs_No_Actuals (Nam) or else Needs_One_Actual (Nam)) - and then - ((Is_Array_Type (Etype (Nam)) - and then Covers (Typ, Component_Type (Etype (Nam)))) - or else (Is_Access_Type (Etype (Nam)) - and then Is_Array_Type (Designated_Type (Etype (Nam))) - and then - Covers (Typ, - Component_Type (Designated_Type (Etype (Nam)))))) - then - declare - Index_Node : Node_Id; - New_Subp : Node_Id; - Ret_Type : constant Entity_Id := Etype (Nam); - - begin - if Is_Access_Type (Ret_Type) - and then Ret_Type = Component_Type (Designated_Type (Ret_Type)) - then - Error_Msg_N - ("cannot disambiguate function call and indexing", N); - else - New_Subp := Relocate_Node (Subp); - Set_Entity (Subp, Nam); - - if Component_Type (Ret_Type) /= Any_Type then - if Needs_No_Actuals (Nam) then - - -- Indexed call to a parameterless function - - Index_Node := - Make_Indexed_Component (Loc, - Prefix => - Make_Function_Call (Loc, - Name => New_Subp), - Expressions => Parameter_Associations (N)); - else - -- An Ada 2005 prefixed call to a primitive operation - -- whose first parameter is the prefix. This prefix was - -- prepended to the parameter list, which is actually a - -- list of indices. Remove the prefix in order to build - -- the proper indexed component. - - Index_Node := - Make_Indexed_Component (Loc, - Prefix => - Make_Function_Call (Loc, - Name => New_Subp, - Parameter_Associations => - New_List - (Remove_Head (Parameter_Associations (N)))), - Expressions => Parameter_Associations (N)); - end if; - - -- Since we are correcting a node classification error made - -- by the parser, we call Replace rather than Rewrite. - - Replace (N, Index_Node); - Set_Etype (Prefix (N), Ret_Type); - Set_Etype (N, Typ); - Resolve_Indexed_Component (N, Typ); - Check_Elab_Call (Prefix (N)); - end if; - end if; - - return; - end; - - else - Set_Etype (N, Etype (Nam)); - end if; - - -- In the case where the call is to an overloaded subprogram, Analyze - -- calls Normalize_Actuals once per overloaded subprogram. Therefore in - -- such a case Normalize_Actuals needs to be called once more to order - -- the actuals correctly. Otherwise the call will have the ordering - -- given by the last overloaded subprogram whether this is the correct - -- one being called or not. - - if Is_Overloaded (Subp) then - Normalize_Actuals (N, Nam, False, Norm_OK); - pragma Assert (Norm_OK); - end if; - - -- In any case, call is fully resolved now. Reset Overload flag, to - -- prevent subsequent overload resolution if node is analyzed again - - Set_Is_Overloaded (Subp, False); - Set_Is_Overloaded (N, False); - - -- If we are calling the current subprogram from immediately within its - -- body, then that is the case where we can sometimes detect cases of - -- infinite recursion statically. Do not try this in case restriction - -- No_Recursion is in effect anyway, and do it only for source calls. - - if Comes_From_Source (N) then - Scop := Current_Scope; - - -- Issue warning for possible infinite recursion in the absence - -- of the No_Recursion restriction. - - if Nam = Scop - and then not Restriction_Active (No_Recursion) - and then Check_Infinite_Recursion (N) - then - -- Here we detected and flagged an infinite recursion, so we do - -- not need to test the case below for further warnings. Also if - -- we now have a raise SE node, we are all done. - - if Nkind (N) = N_Raise_Storage_Error then - return; - end if; - - -- If call is to immediately containing subprogram, then check for - -- the case of a possible run-time detectable infinite recursion. - - else - Scope_Loop : while Scop /= Standard_Standard loop - if Nam = Scop then - - -- Although in general case, recursion is not statically - -- checkable, the case of calling an immediately containing - -- subprogram is easy to catch. - - Check_Restriction (No_Recursion, N); - - -- If the recursive call is to a parameterless subprogram, - -- then even if we can't statically detect infinite - -- recursion, this is pretty suspicious, and we output a - -- warning. Furthermore, we will try later to detect some - -- cases here at run time by expanding checking code (see - -- Detect_Infinite_Recursion in package Exp_Ch6). - - -- If the recursive call is within a handler, do not emit a - -- warning, because this is a common idiom: loop until input - -- is correct, catch illegal input in handler and restart. - - if No (First_Formal (Nam)) - and then Etype (Nam) = Standard_Void_Type - and then not Error_Posted (N) - and then Nkind (Parent (N)) /= N_Exception_Handler - then - -- For the case of a procedure call. We give the message - -- only if the call is the first statement in a sequence - -- of statements, or if all previous statements are - -- simple assignments. This is simply a heuristic to - -- decrease false positives, without losing too many good - -- warnings. The idea is that these previous statements - -- may affect global variables the procedure depends on. - - if Nkind (N) = N_Procedure_Call_Statement - and then Is_List_Member (N) - then - declare - P : Node_Id; - begin - P := Prev (N); - while Present (P) loop - if Nkind (P) /= N_Assignment_Statement then - exit Scope_Loop; - end if; - - Prev (P); - end loop; - end; - end if; - - -- Do not give warning if we are in a conditional context - - declare - K : constant Node_Kind := Nkind (Parent (N)); - begin - if (K = N_Loop_Statement - and then Present (Iteration_Scheme (Parent (N)))) - or else K = N_If_Statement - or else K = N_Elsif_Part - or else K = N_Case_Statement_Alternative - then - exit Scope_Loop; - end if; - end; - - -- Here warning is to be issued - - Set_Has_Recursive_Call (Nam); - Error_Msg_N - ("?possible infinite recursion!", N); - Error_Msg_N - ("\?Storage_Error may be raised at run time!", N); - end if; - - exit Scope_Loop; - end if; - - Scop := Scope (Scop); - end loop Scope_Loop; - end if; - end if; - - -- If subprogram name is a predefined operator, it was given in - -- functional notation. Replace call node with operator node, so - -- that actuals can be resolved appropriately. - - if Is_Predefined_Op (Nam) or else Ekind (Nam) = E_Operator then - Make_Call_Into_Operator (N, Typ, Entity (Name (N))); - return; - - elsif Present (Alias (Nam)) - and then Is_Predefined_Op (Alias (Nam)) - then - Resolve_Actuals (N, Nam); - Make_Call_Into_Operator (N, Typ, Alias (Nam)); - return; - end if; - - -- Create a transient scope if the resulting type requires it - - -- There are 4 notable exceptions: in init procs, the transient scope - -- overhead is not needed and even incorrect due to the actual expansion - -- of adjust calls; the second case is enumeration literal pseudo calls; - -- the third case is intrinsic subprograms (Unchecked_Conversion and - -- source information functions) that do not use the secondary stack - -- even though the return type is unconstrained; the fourth case is a - -- call to a build-in-place function, since such functions may allocate - -- their result directly in a target object, and cases where the result - -- does get allocated in the secondary stack are checked for within the - -- specialized Exp_Ch6 procedures for expanding build-in-place calls. - - -- If this is an initialization call for a type whose initialization - -- uses the secondary stack, we also need to create a transient scope - -- for it, precisely because we will not do it within the init proc - -- itself. - - -- If the subprogram is marked Inline_Always, then even if it returns - -- an unconstrained type the call does not require use of the secondary - -- stack. However, inlining will only take place if the body to inline - -- is already present. It may not be available if e.g. the subprogram is - -- declared in a child instance. - - if Is_Inlined (Nam) - and then Has_Pragma_Inline_Always (Nam) - and then Nkind (Unit_Declaration_Node (Nam)) = N_Subprogram_Declaration - and then Present (Body_To_Inline (Unit_Declaration_Node (Nam))) - then - null; - - elsif Expander_Active - and then Is_Type (Etype (Nam)) - and then Requires_Transient_Scope (Etype (Nam)) - and then not Is_Build_In_Place_Function (Nam) - and then Ekind (Nam) /= E_Enumeration_Literal - and then not Within_Init_Proc - and then not Is_Intrinsic_Subprogram (Nam) - then - Establish_Transient_Scope (N, Sec_Stack => True); - - -- If the call appears within the bounds of a loop, it will - -- be rewritten and reanalyzed, nothing left to do here. - - if Nkind (N) /= N_Function_Call then - return; - end if; - - elsif Is_Init_Proc (Nam) - and then not Within_Init_Proc - then - Check_Initialization_Call (N, Nam); - end if; - - -- A protected function cannot be called within the definition of the - -- enclosing protected type. - - if Is_Protected_Type (Scope (Nam)) - and then In_Open_Scopes (Scope (Nam)) - and then not Has_Completion (Scope (Nam)) - then - Error_Msg_NE - ("& cannot be called before end of protected definition", N, Nam); - end if; - - -- Propagate interpretation to actuals, and add default expressions - -- where needed. - - if Present (First_Formal (Nam)) then - Resolve_Actuals (N, Nam); - - -- Overloaded literals are rewritten as function calls, for - -- purpose of resolution. After resolution, we can replace - -- the call with the literal itself. - - elsif Ekind (Nam) = E_Enumeration_Literal then - Copy_Node (Subp, N); - Resolve_Entity_Name (N, Typ); - - -- Avoid validation, since it is a static function call - - Generate_Reference (Nam, Subp); - return; - end if; - - -- If the subprogram is not global, then kill all saved values and - -- checks. This is a bit conservative, since in many cases we could do - -- better, but it is not worth the effort. Similarly, we kill constant - -- values. However we do not need to do this for internal entities - -- (unless they are inherited user-defined subprograms), since they - -- are not in the business of molesting local values. - - -- If the flag Suppress_Value_Tracking_On_Calls is set, then we also - -- kill all checks and values for calls to global subprograms. This - -- takes care of the case where an access to a local subprogram is - -- taken, and could be passed directly or indirectly and then called - -- from almost any context. - - -- Note: we do not do this step till after resolving the actuals. That - -- way we still take advantage of the current value information while - -- scanning the actuals. - - -- We suppress killing values if we are processing the nodes associated - -- with N_Freeze_Entity nodes. Otherwise the declaration of a tagged - -- type kills all the values as part of analyzing the code that - -- initializes the dispatch tables. - - if Inside_Freezing_Actions = 0 - and then (not Is_Library_Level_Entity (Nam) - or else Suppress_Value_Tracking_On_Call (Current_Scope)) - and then (Comes_From_Source (Nam) - or else (Present (Alias (Nam)) - and then Comes_From_Source (Alias (Nam)))) - then - Kill_Current_Values; - end if; - - -- If we are warning about unread OUT parameters, this is the place to - -- set Last_Assignment for OUT and IN OUT parameters. We have to do this - -- after the above call to Kill_Current_Values (since that call clears - -- the Last_Assignment field of all local variables). - - if (Warn_On_Modified_Unread or Warn_On_All_Unread_Out_Parameters) - and then Comes_From_Source (N) - and then In_Extended_Main_Source_Unit (N) - then - declare - F : Entity_Id; - A : Node_Id; - - begin - F := First_Formal (Nam); - A := First_Actual (N); - while Present (F) and then Present (A) loop - if (Ekind (F) = E_Out_Parameter - or else Ekind (F) = E_In_Out_Parameter) - and then Warn_On_Modified_As_Out_Parameter (F) - and then Is_Entity_Name (A) - and then Present (Entity (A)) - and then Comes_From_Source (N) - and then Safe_To_Capture_Value (N, Entity (A)) - then - Set_Last_Assignment (Entity (A), A); - end if; - - Next_Formal (F); - Next_Actual (A); - end loop; - end; - end if; - - -- If the subprogram is a primitive operation, check whether or not - -- it is a correct dispatching call. - - if Is_Overloadable (Nam) - and then Is_Dispatching_Operation (Nam) - then - Check_Dispatching_Call (N); - - elsif Ekind (Nam) /= E_Subprogram_Type - and then Is_Abstract_Subprogram (Nam) - and then not In_Instance - then - Error_Msg_NE ("cannot call abstract subprogram &!", N, Nam); - end if; - - -- If this is a dispatching call, generate the appropriate reference, - -- for better source navigation in GPS. - - if Is_Overloadable (Nam) - and then Present (Controlling_Argument (N)) - then - Generate_Reference (Nam, Subp, 'R'); - else - Generate_Reference (Nam, Subp); - end if; - - if Is_Intrinsic_Subprogram (Nam) then - Check_Intrinsic_Call (N); - end if; - - -- Check for violation of restriction No_Specific_Termination_Handlers - -- and warn on a potentially blocking call to Abort_Task. - - if Is_RTE (Nam, RE_Set_Specific_Handler) - or else - Is_RTE (Nam, RE_Specific_Handler) - then - Check_Restriction (No_Specific_Termination_Handlers, N); - - elsif Is_RTE (Nam, RE_Abort_Task) then - Check_Potentially_Blocking_Operation (N); - end if; - - -- All done, evaluate call and deal with elaboration issues - - Eval_Call (N); - Check_Elab_Call (N); - end Resolve_Call; - - ------------------------------- - -- Resolve_Character_Literal -- - ------------------------------- - - procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id) is - B_Typ : constant Entity_Id := Base_Type (Typ); - C : Entity_Id; - - begin - -- Verify that the character does belong to the type of the context - - Set_Etype (N, B_Typ); - Eval_Character_Literal (N); - - -- Wide_Wide_Character literals must always be defined, since the set - -- of wide wide character literals is complete, i.e. if a character - -- literal is accepted by the parser, then it is OK for wide wide - -- character (out of range character literals are rejected). - - if Root_Type (B_Typ) = Standard_Wide_Wide_Character then - return; - - -- Always accept character literal for type Any_Character, which - -- occurs in error situations and in comparisons of literals, both - -- of which should accept all literals. - - elsif B_Typ = Any_Character then - return; - - -- For Standard.Character or a type derived from it, check that - -- the literal is in range - - elsif Root_Type (B_Typ) = Standard_Character then - if In_Character_Range (UI_To_CC (Char_Literal_Value (N))) then - return; - end if; - - -- For Standard.Wide_Character or a type derived from it, check - -- that the literal is in range - - elsif Root_Type (B_Typ) = Standard_Wide_Character then - if In_Wide_Character_Range (UI_To_CC (Char_Literal_Value (N))) then - return; - end if; - - -- For Standard.Wide_Wide_Character or a type derived from it, we - -- know the literal is in range, since the parser checked! - - elsif Root_Type (B_Typ) = Standard_Wide_Wide_Character then - return; - - -- If the entity is already set, this has already been resolved in - -- a generic context, or comes from expansion. Nothing else to do. - - elsif Present (Entity (N)) then - return; - - -- Otherwise we have a user defined character type, and we can use - -- the standard visibility mechanisms to locate the referenced entity - - else - C := Current_Entity (N); - while Present (C) loop - if Etype (C) = B_Typ then - Set_Entity_With_Style_Check (N, C); - Generate_Reference (C, N); - return; - end if; - - C := Homonym (C); - end loop; - end if; - - -- If we fall through, then the literal does not match any of the - -- entries of the enumeration type. This isn't just a constraint - -- error situation, it is an illegality (see RM 4.2). - - Error_Msg_NE - ("character not defined for }", N, First_Subtype (B_Typ)); - end Resolve_Character_Literal; - - --------------------------- - -- Resolve_Comparison_Op -- - --------------------------- - - -- Context requires a boolean type, and plays no role in resolution. - -- Processing identical to that for equality operators. The result - -- type is the base type, which matters when pathological subtypes of - -- booleans with limited ranges are used. - - procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id) is - L : constant Node_Id := Left_Opnd (N); - R : constant Node_Id := Right_Opnd (N); - T : Entity_Id; - - begin - -- If this is an intrinsic operation which is not predefined, use - -- the types of its declared arguments to resolve the possibly - -- overloaded operands. Otherwise the operands are unambiguous and - -- specify the expected type. - - if Scope (Entity (N)) /= Standard_Standard then - T := Etype (First_Entity (Entity (N))); - - else - T := Find_Unique_Type (L, R); - - if T = Any_Fixed then - T := Unique_Fixed_Point_Type (L); - end if; - end if; - - Set_Etype (N, Base_Type (Typ)); - Generate_Reference (T, N, ' '); - - if T /= Any_Type then - if T = Any_String - or else T = Any_Composite - or else T = Any_Character - then - if T = Any_Character then - Ambiguous_Character (L); - else - Error_Msg_N ("ambiguous operands for comparison", N); - end if; - - Set_Etype (N, Any_Type); - return; - - else - Resolve (L, T); - Resolve (R, T); - Check_Unset_Reference (L); - Check_Unset_Reference (R); - Generate_Operator_Reference (N, T); - Eval_Relational_Op (N); - end if; - end if; - end Resolve_Comparison_Op; - - ------------------------------------ - -- Resolve_Conditional_Expression -- - ------------------------------------ - - procedure Resolve_Conditional_Expression (N : Node_Id; Typ : Entity_Id) is - Condition : constant Node_Id := First (Expressions (N)); - Then_Expr : constant Node_Id := Next (Condition); - Else_Expr : constant Node_Id := Next (Then_Expr); - - begin - Resolve (Condition, Standard_Boolean); - Resolve (Then_Expr, Typ); - Resolve (Else_Expr, Typ); - - Set_Etype (N, Typ); - Eval_Conditional_Expression (N); - end Resolve_Conditional_Expression; - - ----------------------------------------- - -- Resolve_Discrete_Subtype_Indication -- - ----------------------------------------- - - procedure Resolve_Discrete_Subtype_Indication - (N : Node_Id; - Typ : Entity_Id) - is - R : Node_Id; - S : Entity_Id; - - begin - Analyze (Subtype_Mark (N)); - S := Entity (Subtype_Mark (N)); - - if Nkind (Constraint (N)) /= N_Range_Constraint then - Error_Msg_N ("expect range constraint for discrete type", N); - Set_Etype (N, Any_Type); - - else - R := Range_Expression (Constraint (N)); - - if R = Error then - return; - end if; - - Analyze (R); - - if Base_Type (S) /= Base_Type (Typ) then - Error_Msg_NE - ("expect subtype of }", N, First_Subtype (Typ)); - - -- Rewrite the constraint as a range of Typ - -- to allow compilation to proceed further. - - Set_Etype (N, Typ); - Rewrite (Low_Bound (R), - Make_Attribute_Reference (Sloc (Low_Bound (R)), - Prefix => New_Occurrence_Of (Typ, Sloc (R)), - Attribute_Name => Name_First)); - Rewrite (High_Bound (R), - Make_Attribute_Reference (Sloc (High_Bound (R)), - Prefix => New_Occurrence_Of (Typ, Sloc (R)), - Attribute_Name => Name_First)); - - else - Resolve (R, Typ); - Set_Etype (N, Etype (R)); - - -- Additionally, we must check that the bounds are compatible - -- with the given subtype, which might be different from the - -- type of the context. - - Apply_Range_Check (R, S); - - -- ??? If the above check statically detects a Constraint_Error - -- it replaces the offending bound(s) of the range R with a - -- Constraint_Error node. When the itype which uses these bounds - -- is frozen the resulting call to Duplicate_Subexpr generates - -- a new temporary for the bounds. - - -- Unfortunately there are other itypes that are also made depend - -- on these bounds, so when Duplicate_Subexpr is called they get - -- a forward reference to the newly created temporaries and Gigi - -- aborts on such forward references. This is probably sign of a - -- more fundamental problem somewhere else in either the order of - -- itype freezing or the way certain itypes are constructed. - - -- To get around this problem we call Remove_Side_Effects right - -- away if either bounds of R are a Constraint_Error. - - declare - L : constant Node_Id := Low_Bound (R); - H : constant Node_Id := High_Bound (R); - - begin - if Nkind (L) = N_Raise_Constraint_Error then - Remove_Side_Effects (L); - end if; - - if Nkind (H) = N_Raise_Constraint_Error then - Remove_Side_Effects (H); - end if; - end; - - Check_Unset_Reference (Low_Bound (R)); - Check_Unset_Reference (High_Bound (R)); - end if; - end if; - end Resolve_Discrete_Subtype_Indication; - - ------------------------- - -- Resolve_Entity_Name -- - ------------------------- - - -- Used to resolve identifiers and expanded names - - procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id) is - E : constant Entity_Id := Entity (N); - - begin - -- If garbage from errors, set to Any_Type and return - - if No (E) and then Total_Errors_Detected /= 0 then - Set_Etype (N, Any_Type); - return; - end if; - - -- Replace named numbers by corresponding literals. Note that this is - -- the one case where Resolve_Entity_Name must reset the Etype, since - -- it is currently marked as universal. - - if Ekind (E) = E_Named_Integer then - Set_Etype (N, Typ); - Eval_Named_Integer (N); - - elsif Ekind (E) = E_Named_Real then - Set_Etype (N, Typ); - Eval_Named_Real (N); - - -- Allow use of subtype only if it is a concurrent type where we are - -- currently inside the body. This will eventually be expanded - -- into a call to Self (for tasks) or _object (for protected - -- objects). Any other use of a subtype is invalid. - - elsif Is_Type (E) then - if Is_Concurrent_Type (E) - and then In_Open_Scopes (E) - then - null; - else - Error_Msg_N - ("invalid use of subtype mark in expression or call", N); - end if; - - -- Check discriminant use if entity is discriminant in current scope, - -- i.e. discriminant of record or concurrent type currently being - -- analyzed. Uses in corresponding body are unrestricted. - - elsif Ekind (E) = E_Discriminant - and then Scope (E) = Current_Scope - and then not Has_Completion (Current_Scope) - then - Check_Discriminant_Use (N); - - -- A parameterless generic function cannot appear in a context that - -- requires resolution. - - elsif Ekind (E) = E_Generic_Function then - Error_Msg_N ("illegal use of generic function", N); - - elsif Ekind (E) = E_Out_Parameter - and then Ada_Version = Ada_83 - and then (Nkind (Parent (N)) in N_Op - or else (Nkind (Parent (N)) = N_Assignment_Statement - and then N = Expression (Parent (N))) - or else Nkind (Parent (N)) = N_Explicit_Dereference) - then - Error_Msg_N ("(Ada 83) illegal reading of out parameter", N); - - -- In all other cases, just do the possible static evaluation - - else - -- A deferred constant that appears in an expression must have - -- a completion, unless it has been removed by in-place expansion - -- of an aggregate. - - if Ekind (E) = E_Constant - and then Comes_From_Source (E) - and then No (Constant_Value (E)) - and then Is_Frozen (Etype (E)) - and then not In_Spec_Expression - and then not Is_Imported (E) - then - - if No_Initialization (Parent (E)) - or else (Present (Full_View (E)) - and then No_Initialization (Parent (Full_View (E)))) - then - null; - else - Error_Msg_N ( - "deferred constant is frozen before completion", N); - end if; - end if; - - Eval_Entity_Name (N); - end if; - end Resolve_Entity_Name; - - ------------------- - -- Resolve_Entry -- - ------------------- - - procedure Resolve_Entry (Entry_Name : Node_Id) is - Loc : constant Source_Ptr := Sloc (Entry_Name); - Nam : Entity_Id; - New_N : Node_Id; - S : Entity_Id; - Tsk : Entity_Id; - E_Name : Node_Id; - Index : Node_Id; - - function Actual_Index_Type (E : Entity_Id) return Entity_Id; - -- If the bounds of the entry family being called depend on task - -- discriminants, build a new index subtype where a discriminant is - -- replaced with the value of the discriminant of the target task. - -- The target task is the prefix of the entry name in the call. - - ----------------------- - -- Actual_Index_Type -- - ----------------------- - - function Actual_Index_Type (E : Entity_Id) return Entity_Id is - Typ : constant Entity_Id := Entry_Index_Type (E); - Tsk : constant Entity_Id := Scope (E); - Lo : constant Node_Id := Type_Low_Bound (Typ); - Hi : constant Node_Id := Type_High_Bound (Typ); - New_T : Entity_Id; - - function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id; - -- If the bound is given by a discriminant, replace with a reference - -- to the discriminant of the same name in the target task. - -- If the entry name is the target of a requeue statement and the - -- entry is in the current protected object, the bound to be used - -- is the discriminal of the object (see apply_range_checks for - -- details of the transformation). - - ----------------------------- - -- Actual_Discriminant_Ref -- - ----------------------------- - - function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is - Typ : constant Entity_Id := Etype (Bound); - Ref : Node_Id; - - begin - Remove_Side_Effects (Bound); - - if not Is_Entity_Name (Bound) - or else Ekind (Entity (Bound)) /= E_Discriminant - then - return Bound; - - elsif Is_Protected_Type (Tsk) - and then In_Open_Scopes (Tsk) - and then Nkind (Parent (Entry_Name)) = N_Requeue_Statement - then - return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc); - - else - Ref := - Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Prefix (Prefix (Entry_Name))), - Selector_Name => New_Occurrence_Of (Entity (Bound), Loc)); - Analyze (Ref); - Resolve (Ref, Typ); - return Ref; - end if; - end Actual_Discriminant_Ref; - - -- Start of processing for Actual_Index_Type - - begin - if not Has_Discriminants (Tsk) - or else (not Is_Entity_Name (Lo) - and then not Is_Entity_Name (Hi)) - then - return Entry_Index_Type (E); - - else - New_T := Create_Itype (Ekind (Typ), Parent (Entry_Name)); - Set_Etype (New_T, Base_Type (Typ)); - Set_Size_Info (New_T, Typ); - Set_RM_Size (New_T, RM_Size (Typ)); - Set_Scalar_Range (New_T, - Make_Range (Sloc (Entry_Name), - Low_Bound => Actual_Discriminant_Ref (Lo), - High_Bound => Actual_Discriminant_Ref (Hi))); - - return New_T; - end if; - end Actual_Index_Type; - - -- Start of processing of Resolve_Entry - - begin - -- Find name of entry being called, and resolve prefix of name - -- with its own type. The prefix can be overloaded, and the name - -- and signature of the entry must be taken into account. - - if Nkind (Entry_Name) = N_Indexed_Component then - - -- Case of dealing with entry family within the current tasks - - E_Name := Prefix (Entry_Name); - - else - E_Name := Entry_Name; - end if; - - if Is_Entity_Name (E_Name) then - -- Entry call to an entry (or entry family) in the current task. - -- This is legal even though the task will deadlock. Rewrite as - -- call to current task. - - -- This can also be a call to an entry in an enclosing task. - -- If this is a single task, we have to retrieve its name, - -- because the scope of the entry is the task type, not the - -- object. If the enclosing task is a task type, the identity - -- of the task is given by its own self variable. - - -- Finally this can be a requeue on an entry of the same task - -- or protected object. - - S := Scope (Entity (E_Name)); - - for J in reverse 0 .. Scope_Stack.Last loop - - if Is_Task_Type (Scope_Stack.Table (J).Entity) - and then not Comes_From_Source (S) - then - -- S is an enclosing task or protected object. The concurrent - -- declaration has been converted into a type declaration, and - -- the object itself has an object declaration that follows - -- the type in the same declarative part. - - Tsk := Next_Entity (S); - while Etype (Tsk) /= S loop - Next_Entity (Tsk); - end loop; - - S := Tsk; - exit; - - elsif S = Scope_Stack.Table (J).Entity then - - -- Call to current task. Will be transformed into call to Self - - exit; - - end if; - end loop; - - New_N := - Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (S, Loc), - Selector_Name => - New_Occurrence_Of (Entity (E_Name), Loc)); - Rewrite (E_Name, New_N); - Analyze (E_Name); - - elsif Nkind (Entry_Name) = N_Selected_Component - and then Is_Overloaded (Prefix (Entry_Name)) - then - -- Use the entry name (which must be unique at this point) to - -- find the prefix that returns the corresponding task type or - -- protected type. - - declare - Pref : constant Node_Id := Prefix (Entry_Name); - Ent : constant Entity_Id := Entity (Selector_Name (Entry_Name)); - I : Interp_Index; - It : Interp; - - begin - Get_First_Interp (Pref, I, It); - while Present (It.Typ) loop - if Scope (Ent) = It.Typ then - Set_Etype (Pref, It.Typ); - exit; - end if; - - Get_Next_Interp (I, It); - end loop; - end; - end if; - - if Nkind (Entry_Name) = N_Selected_Component then - Resolve (Prefix (Entry_Name)); - - else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component); - Nam := Entity (Selector_Name (Prefix (Entry_Name))); - Resolve (Prefix (Prefix (Entry_Name))); - Index := First (Expressions (Entry_Name)); - Resolve (Index, Entry_Index_Type (Nam)); - - -- Up to this point the expression could have been the actual - -- in a simple entry call, and be given by a named association. - - if Nkind (Index) = N_Parameter_Association then - Error_Msg_N ("expect expression for entry index", Index); - else - Apply_Range_Check (Index, Actual_Index_Type (Nam)); - end if; - end if; - end Resolve_Entry; - - ------------------------ - -- Resolve_Entry_Call -- - ------------------------ - - procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id) is - Entry_Name : constant Node_Id := Name (N); - Loc : constant Source_Ptr := Sloc (Entry_Name); - Actuals : List_Id; - First_Named : Node_Id; - Nam : Entity_Id; - Norm_OK : Boolean; - Obj : Node_Id; - Was_Over : Boolean; - - begin - -- We kill all checks here, because it does not seem worth the - -- effort to do anything better, an entry call is a big operation. - - Kill_All_Checks; - - -- Processing of the name is similar for entry calls and protected - -- operation calls. Once the entity is determined, we can complete - -- the resolution of the actuals. - - -- The selector may be overloaded, in the case of a protected object - -- with overloaded functions. The type of the context is used for - -- resolution. - - if Nkind (Entry_Name) = N_Selected_Component - and then Is_Overloaded (Selector_Name (Entry_Name)) - and then Typ /= Standard_Void_Type - then - declare - I : Interp_Index; - It : Interp; - - begin - Get_First_Interp (Selector_Name (Entry_Name), I, It); - while Present (It.Typ) loop - if Covers (Typ, It.Typ) then - Set_Entity (Selector_Name (Entry_Name), It.Nam); - Set_Etype (Entry_Name, It.Typ); - - Generate_Reference (It.Typ, N, ' '); - end if; - - Get_Next_Interp (I, It); - end loop; - end; - end if; - - Resolve_Entry (Entry_Name); - - if Nkind (Entry_Name) = N_Selected_Component then - - -- Simple entry call - - Nam := Entity (Selector_Name (Entry_Name)); - Obj := Prefix (Entry_Name); - Was_Over := Is_Overloaded (Selector_Name (Entry_Name)); - - else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component); - - -- Call to member of entry family - - Nam := Entity (Selector_Name (Prefix (Entry_Name))); - Obj := Prefix (Prefix (Entry_Name)); - Was_Over := Is_Overloaded (Selector_Name (Prefix (Entry_Name))); - end if; - - -- We cannot in general check the maximum depth of protected entry - -- calls at compile time. But we can tell that any protected entry - -- call at all violates a specified nesting depth of zero. - - if Is_Protected_Type (Scope (Nam)) then - Check_Restriction (Max_Entry_Queue_Length, N); - end if; - - -- Use context type to disambiguate a protected function that can be - -- called without actuals and that returns an array type, and where - -- the argument list may be an indexing of the returned value. - - if Ekind (Nam) = E_Function - and then Needs_No_Actuals (Nam) - and then Present (Parameter_Associations (N)) - and then - ((Is_Array_Type (Etype (Nam)) - and then Covers (Typ, Component_Type (Etype (Nam)))) - - or else (Is_Access_Type (Etype (Nam)) - and then Is_Array_Type (Designated_Type (Etype (Nam))) - and then Covers (Typ, - Component_Type (Designated_Type (Etype (Nam)))))) - then - declare - Index_Node : Node_Id; - - begin - Index_Node := - Make_Indexed_Component (Loc, - Prefix => - Make_Function_Call (Loc, - Name => Relocate_Node (Entry_Name)), - Expressions => Parameter_Associations (N)); - - -- Since we are correcting a node classification error made by - -- the parser, we call Replace rather than Rewrite. - - Replace (N, Index_Node); - Set_Etype (Prefix (N), Etype (Nam)); - Set_Etype (N, Typ); - Resolve_Indexed_Component (N, Typ); - return; - end; - end if; - - -- The operation name may have been overloaded. Order the actuals - -- according to the formals of the resolved entity, and set the - -- return type to that of the operation. - - if Was_Over then - Normalize_Actuals (N, Nam, False, Norm_OK); - pragma Assert (Norm_OK); - Set_Etype (N, Etype (Nam)); - end if; - - Resolve_Actuals (N, Nam); - Generate_Reference (Nam, Entry_Name); - - if Ekind (Nam) = E_Entry - or else Ekind (Nam) = E_Entry_Family - then - Check_Potentially_Blocking_Operation (N); - end if; - - -- Verify that a procedure call cannot masquerade as an entry - -- call where an entry call is expected. - - if Ekind (Nam) = E_Procedure then - if Nkind (Parent (N)) = N_Entry_Call_Alternative - and then N = Entry_Call_Statement (Parent (N)) - then - Error_Msg_N ("entry call required in select statement", N); - - elsif Nkind (Parent (N)) = N_Triggering_Alternative - and then N = Triggering_Statement (Parent (N)) - then - Error_Msg_N ("triggering statement cannot be procedure call", N); - - elsif Ekind (Scope (Nam)) = E_Task_Type - and then not In_Open_Scopes (Scope (Nam)) - then - Error_Msg_N ("task has no entry with this name", Entry_Name); - end if; - end if; - - -- After resolution, entry calls and protected procedure calls - -- are changed into entry calls, for expansion. The structure - -- of the node does not change, so it can safely be done in place. - -- Protected function calls must keep their structure because they - -- are subexpressions. - - if Ekind (Nam) /= E_Function then - - -- A protected operation that is not a function may modify the - -- corresponding object, and cannot apply to a constant. - -- If this is an internal call, the prefix is the type itself. - - if Is_Protected_Type (Scope (Nam)) - and then not Is_Variable (Obj) - and then (not Is_Entity_Name (Obj) - or else not Is_Type (Entity (Obj))) - then - Error_Msg_N - ("prefix of protected procedure or entry call must be variable", - Entry_Name); - end if; - - Actuals := Parameter_Associations (N); - First_Named := First_Named_Actual (N); - - Rewrite (N, - Make_Entry_Call_Statement (Loc, - Name => Entry_Name, - Parameter_Associations => Actuals)); - - Set_First_Named_Actual (N, First_Named); - Set_Analyzed (N, True); - - -- Protected functions can return on the secondary stack, in which - -- case we must trigger the transient scope mechanism. - - elsif Expander_Active - and then Requires_Transient_Scope (Etype (Nam)) - then - Establish_Transient_Scope (N, Sec_Stack => True); - end if; - end Resolve_Entry_Call; - - ------------------------- - -- Resolve_Equality_Op -- - ------------------------- - - -- Both arguments must have the same type, and the boolean context - -- does not participate in the resolution. The first pass verifies - -- that the interpretation is not ambiguous, and the type of the left - -- argument is correctly set, or is Any_Type in case of ambiguity. - -- If both arguments are strings or aggregates, allocators, or Null, - -- they are ambiguous even though they carry a single (universal) type. - -- Diagnose this case here. - - procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id) is - L : constant Node_Id := Left_Opnd (N); - R : constant Node_Id := Right_Opnd (N); - T : Entity_Id := Find_Unique_Type (L, R); - - function Find_Unique_Access_Type return Entity_Id; - -- In the case of allocators, make a last-ditch attempt to find a single - -- access type with the right designated type. This is semantically - -- dubious, and of no interest to any real code, but c48008a makes it - -- all worthwhile. - - ----------------------------- - -- Find_Unique_Access_Type -- - ----------------------------- - - function Find_Unique_Access_Type return Entity_Id is - Acc : Entity_Id; - E : Entity_Id; - S : Entity_Id; - - begin - if Ekind (Etype (R)) = E_Allocator_Type then - Acc := Designated_Type (Etype (R)); - elsif Ekind (Etype (L)) = E_Allocator_Type then - Acc := Designated_Type (Etype (L)); - else - return Empty; - end if; - - S := Current_Scope; - while S /= Standard_Standard loop - E := First_Entity (S); - while Present (E) loop - if Is_Type (E) - and then Is_Access_Type (E) - and then Ekind (E) /= E_Allocator_Type - and then Designated_Type (E) = Base_Type (Acc) - then - return E; - end if; - - Next_Entity (E); - end loop; - - S := Scope (S); - end loop; - - return Empty; - end Find_Unique_Access_Type; - - -- Start of processing for Resolve_Equality_Op - - begin - Set_Etype (N, Base_Type (Typ)); - Generate_Reference (T, N, ' '); - - if T = Any_Fixed then - T := Unique_Fixed_Point_Type (L); - end if; - - if T /= Any_Type then - if T = Any_String - or else T = Any_Composite - or else T = Any_Character - then - if T = Any_Character then - Ambiguous_Character (L); - else - Error_Msg_N ("ambiguous operands for equality", N); - end if; - - Set_Etype (N, Any_Type); - return; - - elsif T = Any_Access - or else Ekind (T) = E_Allocator_Type - or else Ekind (T) = E_Access_Attribute_Type - then - T := Find_Unique_Access_Type; - - if No (T) then - Error_Msg_N ("ambiguous operands for equality", N); - Set_Etype (N, Any_Type); - return; - end if; - end if; - - Resolve (L, T); - Resolve (R, T); - - -- If the unique type is a class-wide type then it will be expanded - -- into a dispatching call to the predefined primitive. Therefore we - -- check here for potential violation of such restriction. - - if Is_Class_Wide_Type (T) then - Check_Restriction (No_Dispatching_Calls, N); - end if; - - if Warn_On_Redundant_Constructs - and then Comes_From_Source (N) - and then Is_Entity_Name (R) - and then Entity (R) = Standard_True - and then Comes_From_Source (R) - then - Error_Msg_N ("?comparison with True is redundant!", R); - end if; - - Check_Unset_Reference (L); - Check_Unset_Reference (R); - Generate_Operator_Reference (N, T); - - -- If this is an inequality, it may be the implicit inequality - -- created for a user-defined operation, in which case the corres- - -- ponding equality operation is not intrinsic, and the operation - -- cannot be constant-folded. Else fold. - - if Nkind (N) = N_Op_Eq - or else Comes_From_Source (Entity (N)) - or else Ekind (Entity (N)) = E_Operator - or else Is_Intrinsic_Subprogram - (Corresponding_Equality (Entity (N))) - then - Eval_Relational_Op (N); - - elsif Nkind (N) = N_Op_Ne - and then Is_Abstract_Subprogram (Entity (N)) - then - Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N)); - end if; - - -- Ada 2005: If one operand is an anonymous access type, convert - -- the other operand to it, to ensure that the underlying types - -- match in the back-end. Same for access_to_subprogram, and the - -- conversion verifies that the types are subtype conformant. - - -- We apply the same conversion in the case one of the operands is - -- a private subtype of the type of the other. - - -- Why the Expander_Active test here ??? - - if Expander_Active - and then - (Ekind (T) = E_Anonymous_Access_Type - or else Ekind (T) = E_Anonymous_Access_Subprogram_Type - or else Is_Private_Type (T)) - then - if Etype (L) /= T then - Rewrite (L, - Make_Unchecked_Type_Conversion (Sloc (L), - Subtype_Mark => New_Occurrence_Of (T, Sloc (L)), - Expression => Relocate_Node (L))); - Analyze_And_Resolve (L, T); - end if; - - if (Etype (R)) /= T then - Rewrite (R, - Make_Unchecked_Type_Conversion (Sloc (R), - Subtype_Mark => New_Occurrence_Of (Etype (L), Sloc (R)), - Expression => Relocate_Node (R))); - Analyze_And_Resolve (R, T); - end if; - end if; - end if; - end Resolve_Equality_Op; - - ---------------------------------- - -- Resolve_Explicit_Dereference -- - ---------------------------------- - - procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id) is - Loc : constant Source_Ptr := Sloc (N); - New_N : Node_Id; - P : constant Node_Id := Prefix (N); - I : Interp_Index; - It : Interp; - - begin - Check_Fully_Declared_Prefix (Typ, P); - - if Is_Overloaded (P) then - - -- Use the context type to select the prefix that has the correct - -- designated type. - - Get_First_Interp (P, I, It); - while Present (It.Typ) loop - exit when Is_Access_Type (It.Typ) - and then Covers (Typ, Designated_Type (It.Typ)); - Get_Next_Interp (I, It); - end loop; - - if Present (It.Typ) then - Resolve (P, It.Typ); - else - -- If no interpretation covers the designated type of the prefix, - -- this is the pathological case where not all implementations of - -- the prefix allow the interpretation of the node as a call. Now - -- that the expected type is known, Remove other interpretations - -- from prefix, rewrite it as a call, and resolve again, so that - -- the proper call node is generated. - - Get_First_Interp (P, I, It); - while Present (It.Typ) loop - if Ekind (It.Typ) /= E_Access_Subprogram_Type then - Remove_Interp (I); - end if; - - Get_Next_Interp (I, It); - end loop; - - New_N := - Make_Function_Call (Loc, - Name => - Make_Explicit_Dereference (Loc, - Prefix => P), - Parameter_Associations => New_List); - - Save_Interps (N, New_N); - Rewrite (N, New_N); - Analyze_And_Resolve (N, Typ); - return; - end if; - - Set_Etype (N, Designated_Type (It.Typ)); - - else - Resolve (P); - end if; - - if Is_Access_Type (Etype (P)) then - Apply_Access_Check (N); - end if; - - -- If the designated type is a packed unconstrained array type, and the - -- explicit dereference is not in the context of an attribute reference, - -- then we must compute and set the actual subtype, since it is needed - -- by Gigi. The reason we exclude the attribute case is that this is - -- handled fine by Gigi, and in fact we use such attributes to build the - -- actual subtype. We also exclude generated code (which builds actual - -- subtypes directly if they are needed). - - if Is_Array_Type (Etype (N)) - and then Is_Packed (Etype (N)) - and then not Is_Constrained (Etype (N)) - and then Nkind (Parent (N)) /= N_Attribute_Reference - and then Comes_From_Source (N) - then - Set_Etype (N, Get_Actual_Subtype (N)); - end if; - - -- Note: there is no Eval processing required for an explicit deference, - -- because the type is known to be an allocators, and allocator - -- expressions can never be static. - - end Resolve_Explicit_Dereference; - - ------------------------------- - -- Resolve_Indexed_Component -- - ------------------------------- - - procedure Resolve_Indexed_Component (N : Node_Id; Typ : Entity_Id) is - Name : constant Node_Id := Prefix (N); - Expr : Node_Id; - Array_Type : Entity_Id := Empty; -- to prevent junk warning - Index : Node_Id; - - begin - if Is_Overloaded (Name) then - - -- Use the context type to select the prefix that yields the correct - -- component type. - - declare - I : Interp_Index; - It : Interp; - I1 : Interp_Index := 0; - P : constant Node_Id := Prefix (N); - Found : Boolean := False; - - begin - Get_First_Interp (P, I, It); - while Present (It.Typ) loop - if (Is_Array_Type (It.Typ) - and then Covers (Typ, Component_Type (It.Typ))) - or else (Is_Access_Type (It.Typ) - and then Is_Array_Type (Designated_Type (It.Typ)) - and then Covers - (Typ, Component_Type (Designated_Type (It.Typ)))) - then - if Found then - It := Disambiguate (P, I1, I, Any_Type); - - if It = No_Interp then - Error_Msg_N ("ambiguous prefix for indexing", N); - Set_Etype (N, Typ); - return; - - else - Found := True; - Array_Type := It.Typ; - I1 := I; - end if; - - else - Found := True; - Array_Type := It.Typ; - I1 := I; - end if; - end if; - - Get_Next_Interp (I, It); - end loop; - end; - - else - Array_Type := Etype (Name); - end if; - - Resolve (Name, Array_Type); - Array_Type := Get_Actual_Subtype_If_Available (Name); - - -- If prefix is access type, dereference to get real array type. - -- Note: we do not apply an access check because the expander always - -- introduces an explicit dereference, and the check will happen there. - - if Is_Access_Type (Array_Type) then - Array_Type := Designated_Type (Array_Type); - end if; - - -- If name was overloaded, set component type correctly now - -- If a misplaced call to an entry family (which has no index types) - -- return. Error will be diagnosed from calling context. - - if Is_Array_Type (Array_Type) then - Set_Etype (N, Component_Type (Array_Type)); - else - return; - end if; - - Index := First_Index (Array_Type); - Expr := First (Expressions (N)); - - -- The prefix may have resolved to a string literal, in which case its - -- etype has a special representation. This is only possible currently - -- if the prefix is a static concatenation, written in functional - -- notation. - - if Ekind (Array_Type) = E_String_Literal_Subtype then - Resolve (Expr, Standard_Positive); - - else - while Present (Index) and Present (Expr) loop - Resolve (Expr, Etype (Index)); - Check_Unset_Reference (Expr); - - if Is_Scalar_Type (Etype (Expr)) then - Apply_Scalar_Range_Check (Expr, Etype (Index)); - else - Apply_Range_Check (Expr, Get_Actual_Subtype (Index)); - end if; - - Next_Index (Index); - Next (Expr); - end loop; - end if; - - -- Do not generate the warning on suspicious index if we are analyzing - -- package Ada.Tags; otherwise we will report the warning with the - -- Prims_Ptr field of the dispatch table. - - if Scope (Etype (Prefix (N))) = Standard_Standard - or else not - Is_RTU (Cunit_Entity (Get_Source_Unit (Etype (Prefix (N)))), - Ada_Tags) - then - Warn_On_Suspicious_Index (Name, First (Expressions (N))); - Eval_Indexed_Component (N); - end if; - end Resolve_Indexed_Component; - - ----------------------------- - -- Resolve_Integer_Literal -- - ----------------------------- - - procedure Resolve_Integer_Literal (N : Node_Id; Typ : Entity_Id) is - begin - Set_Etype (N, Typ); - Eval_Integer_Literal (N); - end Resolve_Integer_Literal; - - -------------------------------- - -- Resolve_Intrinsic_Operator -- - -------------------------------- - - procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id) is - Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ)); - Op : Entity_Id; - Arg1 : Node_Id; - Arg2 : Node_Id; - - begin - Op := Entity (N); - while Scope (Op) /= Standard_Standard loop - Op := Homonym (Op); - pragma Assert (Present (Op)); - end loop; - - Set_Entity (N, Op); - Set_Is_Overloaded (N, False); - - -- If the operand type is private, rewrite with suitable conversions on - -- the operands and the result, to expose the proper underlying numeric - -- type. - - if Is_Private_Type (Typ) then - Arg1 := Unchecked_Convert_To (Btyp, Left_Opnd (N)); - - if Nkind (N) = N_Op_Expon then - Arg2 := Unchecked_Convert_To (Standard_Integer, Right_Opnd (N)); - else - Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N)); - end if; - - Save_Interps (Left_Opnd (N), Expression (Arg1)); - Save_Interps (Right_Opnd (N), Expression (Arg2)); - - Set_Left_Opnd (N, Arg1); - Set_Right_Opnd (N, Arg2); - - Set_Etype (N, Btyp); - Rewrite (N, Unchecked_Convert_To (Typ, N)); - Resolve (N, Typ); - - elsif Typ /= Etype (Left_Opnd (N)) - or else Typ /= Etype (Right_Opnd (N)) - then - -- Add explicit conversion where needed, and save interpretations - -- in case operands are overloaded. - - Arg1 := Convert_To (Typ, Left_Opnd (N)); - Arg2 := Convert_To (Typ, Right_Opnd (N)); - - if Nkind (Arg1) = N_Type_Conversion then - Save_Interps (Left_Opnd (N), Expression (Arg1)); - else - Save_Interps (Left_Opnd (N), Arg1); - end if; - - if Nkind (Arg2) = N_Type_Conversion then - Save_Interps (Right_Opnd (N), Expression (Arg2)); - else - Save_Interps (Right_Opnd (N), Arg2); - end if; - - Rewrite (Left_Opnd (N), Arg1); - Rewrite (Right_Opnd (N), Arg2); - Analyze (Arg1); - Analyze (Arg2); - Resolve_Arithmetic_Op (N, Typ); - - else - Resolve_Arithmetic_Op (N, Typ); - end if; - end Resolve_Intrinsic_Operator; - - -------------------------------------- - -- Resolve_Intrinsic_Unary_Operator -- - -------------------------------------- - - procedure Resolve_Intrinsic_Unary_Operator - (N : Node_Id; - Typ : Entity_Id) - is - Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ)); - Op : Entity_Id; - Arg2 : Node_Id; - - begin - Op := Entity (N); - while Scope (Op) /= Standard_Standard loop - Op := Homonym (Op); - pragma Assert (Present (Op)); - end loop; - - Set_Entity (N, Op); - - if Is_Private_Type (Typ) then - Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N)); - Save_Interps (Right_Opnd (N), Expression (Arg2)); - - Set_Right_Opnd (N, Arg2); - - Set_Etype (N, Btyp); - Rewrite (N, Unchecked_Convert_To (Typ, N)); - Resolve (N, Typ); - - else - Resolve_Unary_Op (N, Typ); - end if; - end Resolve_Intrinsic_Unary_Operator; - - ------------------------ - -- Resolve_Logical_Op -- - ------------------------ - - procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id) is - B_Typ : Entity_Id; - N_Opr : constant Node_Kind := Nkind (N); - - begin - -- Predefined operations on scalar types yield the base type. On the - -- other hand, logical operations on arrays yield the type of the - -- arguments (and the context). - - if Is_Array_Type (Typ) then - B_Typ := Typ; - else - B_Typ := Base_Type (Typ); - end if; - - -- The following test is required because the operands of the operation - -- may be literals, in which case the resulting type appears to be - -- compatible with a signed integer type, when in fact it is compatible - -- only with modular types. If the context itself is universal, the - -- operation is illegal. - - if not Valid_Boolean_Arg (Typ) then - Error_Msg_N ("invalid context for logical operation", N); - Set_Etype (N, Any_Type); - return; - - elsif Typ = Any_Modular then - Error_Msg_N - ("no modular type available in this context", N); - Set_Etype (N, Any_Type); - return; - elsif Is_Modular_Integer_Type (Typ) - and then Etype (Left_Opnd (N)) = Universal_Integer - and then Etype (Right_Opnd (N)) = Universal_Integer - then - Check_For_Visible_Operator (N, B_Typ); - end if; - - Resolve (Left_Opnd (N), B_Typ); - Resolve (Right_Opnd (N), B_Typ); - - Check_Unset_Reference (Left_Opnd (N)); - Check_Unset_Reference (Right_Opnd (N)); - - Set_Etype (N, B_Typ); - Generate_Operator_Reference (N, B_Typ); - Eval_Logical_Op (N); - - -- Check for violation of restriction No_Direct_Boolean_Operators - -- if the operator was not eliminated by the Eval_Logical_Op call. - - if Nkind (N) = N_Opr - and then Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean - then - Check_Restriction (No_Direct_Boolean_Operators, N); - end if; - end Resolve_Logical_Op; - - --------------------------- - -- Resolve_Membership_Op -- - --------------------------- - - -- The context can only be a boolean type, and does not determine - -- the arguments. Arguments should be unambiguous, but the preference - -- rule for universal types applies. - - procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id) is - pragma Warnings (Off, Typ); - - L : constant Node_Id := Left_Opnd (N); - R : constant Node_Id := Right_Opnd (N); - T : Entity_Id; - - begin - if L = Error or else R = Error then - return; - end if; - - if not Is_Overloaded (R) - and then - (Etype (R) = Universal_Integer or else - Etype (R) = Universal_Real) - and then Is_Overloaded (L) - then - T := Etype (R); - - -- Ada 2005 (AI-251): Give support to the following case: - - -- type I is interface; - -- type T is tagged ... - - -- function Test (O : I'Class) is - -- begin - -- return O in T'Class. - -- end Test; - - -- In this case we have nothing else to do; the membership test will be - -- done at run-time. - - elsif Ada_Version >= Ada_05 - and then Is_Class_Wide_Type (Etype (L)) - and then Is_Interface (Etype (L)) - and then Is_Class_Wide_Type (Etype (R)) - and then not Is_Interface (Etype (R)) - then - return; - - else - T := Intersect_Types (L, R); - end if; - - Resolve (L, T); - Check_Unset_Reference (L); - - if Nkind (R) = N_Range - and then not Is_Scalar_Type (T) - then - Error_Msg_N ("scalar type required for range", R); - end if; - - if Is_Entity_Name (R) then - Freeze_Expression (R); - else - Resolve (R, T); - Check_Unset_Reference (R); - end if; - - Eval_Membership_Op (N); - end Resolve_Membership_Op; - - ------------------ - -- Resolve_Null -- - ------------------ - - procedure Resolve_Null (N : Node_Id; Typ : Entity_Id) is - Loc : constant Source_Ptr := Sloc (N); - - begin - -- Handle restriction against anonymous null access values This - -- restriction can be turned off using -gnatdj. - - -- Ada 2005 (AI-231): Remove restriction - - if Ada_Version < Ada_05 - and then not Debug_Flag_J - and then Ekind (Typ) = E_Anonymous_Access_Type - and then Comes_From_Source (N) - then - -- In the common case of a call which uses an explicitly null - -- value for an access parameter, give specialized error message. - - if Nkind_In (Parent (N), N_Procedure_Call_Statement, - N_Function_Call) - then - Error_Msg_N - ("null is not allowed as argument for an access parameter", N); - - -- Standard message for all other cases (are there any?) - - else - Error_Msg_N - ("null cannot be of an anonymous access type", N); - end if; - end if; - - -- Ada 2005 (AI-231): Generate the null-excluding check in case of - -- assignment to a null-excluding object - - if Ada_Version >= Ada_05 - and then Can_Never_Be_Null (Typ) - and then Nkind (Parent (N)) = N_Assignment_Statement - then - if not Inside_Init_Proc then - Insert_Action - (Compile_Time_Constraint_Error (N, - "(Ada 2005) null not allowed in null-excluding objects?"), - Make_Raise_Constraint_Error (Loc, - Reason => CE_Access_Check_Failed)); - else - Insert_Action (N, - Make_Raise_Constraint_Error (Loc, - Reason => CE_Access_Check_Failed)); - end if; - end if; - - -- In a distributed context, null for a remote access to subprogram - -- may need to be replaced with a special record aggregate. In this - -- case, return after having done the transformation. - - if (Ekind (Typ) = E_Record_Type - or else Is_Remote_Access_To_Subprogram_Type (Typ)) - and then Remote_AST_Null_Value (N, Typ) - then - return; - end if; - - -- The null literal takes its type from the context - - Set_Etype (N, Typ); - end Resolve_Null; - - ----------------------- - -- Resolve_Op_Concat -- - ----------------------- - - procedure Resolve_Op_Concat (N : Node_Id; Typ : Entity_Id) is - - -- We wish to avoid deep recursion, because concatenations are often - -- deeply nested, as in A&B&...&Z. Therefore, we walk down the left - -- operands nonrecursively until we find something that is not a simple - -- concatenation (A in this case). We resolve that, and then walk back - -- up the tree following Parent pointers, calling Resolve_Op_Concat_Rest - -- to do the rest of the work at each level. The Parent pointers allow - -- us to avoid recursion, and thus avoid running out of memory. See also - -- Sem_Ch4.Analyze_Concatenation, where a similar hack is used. - - NN : Node_Id := N; - Op1 : Node_Id; - - begin - -- The following code is equivalent to: - - -- Resolve_Op_Concat_First (NN, Typ); - -- Resolve_Op_Concat_Arg (N, ...); - -- Resolve_Op_Concat_Rest (N, Typ); - - -- where the Resolve_Op_Concat_Arg call recurses back here if the left - -- operand is a concatenation. - - -- Walk down left operands - - loop - Resolve_Op_Concat_First (NN, Typ); - Op1 := Left_Opnd (NN); - exit when not (Nkind (Op1) = N_Op_Concat - and then not Is_Array_Type (Component_Type (Typ)) - and then Entity (Op1) = Entity (NN)); - NN := Op1; - end loop; - - -- Now (given the above example) NN is A&B and Op1 is A - - -- First resolve Op1 ... - - Resolve_Op_Concat_Arg (NN, Op1, Typ, Is_Component_Left_Opnd (NN)); - - -- ... then walk NN back up until we reach N (where we started), calling - -- Resolve_Op_Concat_Rest along the way. - - loop - Resolve_Op_Concat_Rest (NN, Typ); - exit when NN = N; - NN := Parent (NN); - end loop; - end Resolve_Op_Concat; - - --------------------------- - -- Resolve_Op_Concat_Arg -- - --------------------------- - - procedure Resolve_Op_Concat_Arg - (N : Node_Id; - Arg : Node_Id; - Typ : Entity_Id; - Is_Comp : Boolean) - is - Btyp : constant Entity_Id := Base_Type (Typ); - - begin - if In_Instance then - if Is_Comp - or else (not Is_Overloaded (Arg) - and then Etype (Arg) /= Any_Composite - and then Covers (Component_Type (Typ), Etype (Arg))) - then - Resolve (Arg, Component_Type (Typ)); - else - Resolve (Arg, Btyp); - end if; - - elsif Has_Compatible_Type (Arg, Component_Type (Typ)) then - if Nkind (Arg) = N_Aggregate - and then Is_Composite_Type (Component_Type (Typ)) - then - if Is_Private_Type (Component_Type (Typ)) then - Resolve (Arg, Btyp); - else - Error_Msg_N ("ambiguous aggregate must be qualified", Arg); - Set_Etype (Arg, Any_Type); - end if; - - else - if Is_Overloaded (Arg) - and then Has_Compatible_Type (Arg, Typ) - and then Etype (Arg) /= Any_Type - then - declare - I : Interp_Index; - It : Interp; - Func : Entity_Id; - - begin - Get_First_Interp (Arg, I, It); - Func := It.Nam; - Get_Next_Interp (I, It); - - -- Special-case the error message when the overloading is - -- caused by a function that yields an array and can be - -- called without parameters. - - if It.Nam = Func then - Error_Msg_Sloc := Sloc (Func); - Error_Msg_N ("ambiguous call to function#", Arg); - Error_Msg_NE - ("\\interpretation as call yields&", Arg, Typ); - Error_Msg_NE - ("\\interpretation as indexing of call yields&", - Arg, Component_Type (Typ)); - - else - Error_Msg_N - ("ambiguous operand for concatenation!", Arg); - Get_First_Interp (Arg, I, It); - while Present (It.Nam) loop - Error_Msg_Sloc := Sloc (It.Nam); - - if Base_Type (It.Typ) = Base_Type (Typ) - or else Base_Type (It.Typ) = - Base_Type (Component_Type (Typ)) - then - Error_Msg_N ("\\possible interpretation#", Arg); - end if; - - Get_Next_Interp (I, It); - end loop; - end if; - end; - end if; - - Resolve (Arg, Component_Type (Typ)); - - if Nkind (Arg) = N_String_Literal then - Set_Etype (Arg, Component_Type (Typ)); - end if; - - if Arg = Left_Opnd (N) then - Set_Is_Component_Left_Opnd (N); - else - Set_Is_Component_Right_Opnd (N); - end if; - end if; - - else - Resolve (Arg, Btyp); - end if; - - Check_Unset_Reference (Arg); - end Resolve_Op_Concat_Arg; - - ----------------------------- - -- Resolve_Op_Concat_First -- - ----------------------------- - - procedure Resolve_Op_Concat_First (N : Node_Id; Typ : Entity_Id) is - Btyp : constant Entity_Id := Base_Type (Typ); - Op1 : constant Node_Id := Left_Opnd (N); - Op2 : constant Node_Id := Right_Opnd (N); - - begin - -- The parser folds an enormous sequence of concatenations of string - -- literals into "" & "...", where the Is_Folded_In_Parser flag is set - -- in the right. If the expression resolves to a predefined "&" - -- operator, all is well. Otherwise, the parser's folding is wrong, so - -- we give an error. See P_Simple_Expression in Par.Ch4. - - if Nkind (Op2) = N_String_Literal - and then Is_Folded_In_Parser (Op2) - and then Ekind (Entity (N)) = E_Function - then - pragma Assert (Nkind (Op1) = N_String_Literal -- should be "" - and then String_Length (Strval (Op1)) = 0); - Error_Msg_N ("too many user-defined concatenations", N); - return; - end if; - - Set_Etype (N, Btyp); - - if Is_Limited_Composite (Btyp) then - Error_Msg_N ("concatenation not available for limited array", N); - Explain_Limited_Type (Btyp, N); - end if; - end Resolve_Op_Concat_First; - - ---------------------------- - -- Resolve_Op_Concat_Rest -- - ---------------------------- - - procedure Resolve_Op_Concat_Rest (N : Node_Id; Typ : Entity_Id) is - Op1 : constant Node_Id := Left_Opnd (N); - Op2 : constant Node_Id := Right_Opnd (N); - - begin - Resolve_Op_Concat_Arg (N, Op2, Typ, Is_Component_Right_Opnd (N)); - - Generate_Operator_Reference (N, Typ); - - if Is_String_Type (Typ) then - Eval_Concatenation (N); - end if; - - -- If this is not a static concatenation, but the result is a - -- string type (and not an array of strings) ensure that static - -- string operands have their subtypes properly constructed. - - if Nkind (N) /= N_String_Literal - and then Is_Character_Type (Component_Type (Typ)) - then - Set_String_Literal_Subtype (Op1, Typ); - Set_String_Literal_Subtype (Op2, Typ); - end if; - end Resolve_Op_Concat_Rest; - - ---------------------- - -- Resolve_Op_Expon -- - ---------------------- - - procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id) is - B_Typ : constant Entity_Id := Base_Type (Typ); - - begin - -- Catch attempts to do fixed-point exponentiation with universal - -- operands, which is a case where the illegality is not caught during - -- normal operator analysis. - - if Is_Fixed_Point_Type (Typ) and then Comes_From_Source (N) then - Error_Msg_N ("exponentiation not available for fixed point", N); - return; - end if; - - if Comes_From_Source (N) - and then Ekind (Entity (N)) = E_Function - and then Is_Imported (Entity (N)) - and then Is_Intrinsic_Subprogram (Entity (N)) - then - Resolve_Intrinsic_Operator (N, Typ); - return; - end if; - - if Etype (Left_Opnd (N)) = Universal_Integer - or else Etype (Left_Opnd (N)) = Universal_Real - then - Check_For_Visible_Operator (N, B_Typ); - end if; - - -- We do the resolution using the base type, because intermediate values - -- in expressions always are of the base type, not a subtype of it. - - Resolve (Left_Opnd (N), B_Typ); - Resolve (Right_Opnd (N), Standard_Integer); - - Check_Unset_Reference (Left_Opnd (N)); - Check_Unset_Reference (Right_Opnd (N)); - - Set_Etype (N, B_Typ); - Generate_Operator_Reference (N, B_Typ); - Eval_Op_Expon (N); - - -- Set overflow checking bit. Much cleverer code needed here eventually - -- and perhaps the Resolve routines should be separated for the various - -- arithmetic operations, since they will need different processing. ??? - - if Nkind (N) in N_Op then - if not Overflow_Checks_Suppressed (Etype (N)) then - Enable_Overflow_Check (N); - end if; - end if; - end Resolve_Op_Expon; - - -------------------- - -- Resolve_Op_Not -- - -------------------- - - procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id) is - B_Typ : Entity_Id; - - function Parent_Is_Boolean return Boolean; - -- This function determines if the parent node is a boolean operator - -- or operation (comparison op, membership test, or short circuit form) - -- and the not in question is the left operand of this operation. - -- Note that if the not is in parens, then false is returned. - - ----------------------- - -- Parent_Is_Boolean -- - ----------------------- - - function Parent_Is_Boolean return Boolean is - begin - if Paren_Count (N) /= 0 then - return False; - - else - case Nkind (Parent (N)) is - when N_Op_And | - N_Op_Eq | - N_Op_Ge | - N_Op_Gt | - N_Op_Le | - N_Op_Lt | - N_Op_Ne | - N_Op_Or | - N_Op_Xor | - N_In | - N_Not_In | - N_And_Then | - N_Or_Else => - - return Left_Opnd (Parent (N)) = N; - - when others => - return False; - end case; - end if; - end Parent_Is_Boolean; - - -- Start of processing for Resolve_Op_Not - - begin - -- Predefined operations on scalar types yield the base type. On the - -- other hand, logical operations on arrays yield the type of the - -- arguments (and the context). - - if Is_Array_Type (Typ) then - B_Typ := Typ; - else - B_Typ := Base_Type (Typ); - end if; - - -- Straightforward case of incorrect arguments - - if not Valid_Boolean_Arg (Typ) then - Error_Msg_N ("invalid operand type for operator&", N); - Set_Etype (N, Any_Type); - return; - - -- Special case of probable missing parens - - elsif Typ = Universal_Integer or else Typ = Any_Modular then - if Parent_Is_Boolean then - Error_Msg_N - ("operand of not must be enclosed in parentheses", - Right_Opnd (N)); - else - Error_Msg_N - ("no modular type available in this context", N); - end if; - - Set_Etype (N, Any_Type); - return; - - -- OK resolution of not - - else - -- Warn if non-boolean types involved. This is a case like not a < b - -- where a and b are modular, where we will get (not a) < b and most - -- likely not (a < b) was intended. - - if Warn_On_Questionable_Missing_Parens - and then not Is_Boolean_Type (Typ) - and then Parent_Is_Boolean - then - Error_Msg_N ("?not expression should be parenthesized here!", N); - end if; - - -- Warn on double negation if checking redundant constructs - - if Warn_On_Redundant_Constructs - and then Comes_From_Source (N) - and then Comes_From_Source (Right_Opnd (N)) - and then Root_Type (Typ) = Standard_Boolean - and then Nkind (Right_Opnd (N)) = N_Op_Not - then - Error_Msg_N ("redundant double negation?", N); - end if; - - -- Complete resolution and evaluation of NOT - - Resolve (Right_Opnd (N), B_Typ); - Check_Unset_Reference (Right_Opnd (N)); - Set_Etype (N, B_Typ); - Generate_Operator_Reference (N, B_Typ); - Eval_Op_Not (N); - end if; - end Resolve_Op_Not; - - ----------------------------- - -- Resolve_Operator_Symbol -- - ----------------------------- - - -- Nothing to be done, all resolved already - - procedure Resolve_Operator_Symbol (N : Node_Id; Typ : Entity_Id) is - pragma Warnings (Off, N); - pragma Warnings (Off, Typ); - - begin - null; - end Resolve_Operator_Symbol; - - ---------------------------------- - -- Resolve_Qualified_Expression -- - ---------------------------------- - - procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id) is - pragma Warnings (Off, Typ); - - Target_Typ : constant Entity_Id := Entity (Subtype_Mark (N)); - Expr : constant Node_Id := Expression (N); - - begin - Resolve (Expr, Target_Typ); - - -- A qualified expression requires an exact match of the type, - -- class-wide matching is not allowed. However, if the qualifying - -- type is specific and the expression has a class-wide type, it - -- may still be okay, since it can be the result of the expansion - -- of a call to a dispatching function, so we also have to check - -- class-wideness of the type of the expression's original node. - - if (Is_Class_Wide_Type (Target_Typ) - or else - (Is_Class_Wide_Type (Etype (Expr)) - and then Is_Class_Wide_Type (Etype (Original_Node (Expr))))) - and then Base_Type (Etype (Expr)) /= Base_Type (Target_Typ) - then - Wrong_Type (Expr, Target_Typ); - end if; - - -- If the target type is unconstrained, then we reset the type of - -- the result from the type of the expression. For other cases, the - -- actual subtype of the expression is the target type. - - if Is_Composite_Type (Target_Typ) - and then not Is_Constrained (Target_Typ) - then - Set_Etype (N, Etype (Expr)); - end if; - - Eval_Qualified_Expression (N); - end Resolve_Qualified_Expression; - - ------------------- - -- Resolve_Range -- - ------------------- - - procedure Resolve_Range (N : Node_Id; Typ : Entity_Id) is - L : constant Node_Id := Low_Bound (N); - H : constant Node_Id := High_Bound (N); - - begin - Set_Etype (N, Typ); - Resolve (L, Typ); - Resolve (H, Typ); - - Check_Unset_Reference (L); - Check_Unset_Reference (H); - - -- We have to check the bounds for being within the base range as - -- required for a non-static context. Normally this is automatic and - -- done as part of evaluating expressions, but the N_Range node is an - -- exception, since in GNAT we consider this node to be a subexpression, - -- even though in Ada it is not. The circuit in Sem_Eval could check for - -- this, but that would put the test on the main evaluation path for - -- expressions. - - Check_Non_Static_Context (L); - Check_Non_Static_Context (H); - - -- Check for an ambiguous range over character literals. This will - -- happen with a membership test involving only literals. - - if Typ = Any_Character then - Ambiguous_Character (L); - Set_Etype (N, Any_Type); - return; - end if; - - -- If bounds are static, constant-fold them, so size computations - -- are identical between front-end and back-end. Do not perform this - -- transformation while analyzing generic units, as type information - -- would then be lost when reanalyzing the constant node in the - -- instance. - - if Is_Discrete_Type (Typ) and then Expander_Active then - if Is_OK_Static_Expression (L) then - Fold_Uint (L, Expr_Value (L), Is_Static_Expression (L)); - end if; - - if Is_OK_Static_Expression (H) then - Fold_Uint (H, Expr_Value (H), Is_Static_Expression (H)); - end if; - end if; - end Resolve_Range; - - -------------------------- - -- Resolve_Real_Literal -- - -------------------------- - - procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id) is - Actual_Typ : constant Entity_Id := Etype (N); - - begin - -- Special processing for fixed-point literals to make sure that the - -- value is an exact multiple of small where this is required. We - -- skip this for the universal real case, and also for generic types. - - if Is_Fixed_Point_Type (Typ) - and then Typ /= Universal_Fixed - and then Typ /= Any_Fixed - and then not Is_Generic_Type (Typ) - then - declare - Val : constant Ureal := Realval (N); - Cintr : constant Ureal := Val / Small_Value (Typ); - Cint : constant Uint := UR_Trunc (Cintr); - Den : constant Uint := Norm_Den (Cintr); - Stat : Boolean; - - begin - -- Case of literal is not an exact multiple of the Small - - if Den /= 1 then - - -- For a source program literal for a decimal fixed-point - -- type, this is statically illegal (RM 4.9(36)). - - if Is_Decimal_Fixed_Point_Type (Typ) - and then Actual_Typ = Universal_Real - and then Comes_From_Source (N) - then - Error_Msg_N ("value has extraneous low order digits", N); - end if; - - -- Generate a warning if literal from source - - if Is_Static_Expression (N) - and then Warn_On_Bad_Fixed_Value - then - Error_Msg_N - ("?static fixed-point value is not a multiple of Small!", - N); - end if; - - -- Replace literal by a value that is the exact representation - -- of a value of the type, i.e. a multiple of the small value, - -- by truncation, since Machine_Rounds is false for all GNAT - -- fixed-point types (RM 4.9(38)). - - Stat := Is_Static_Expression (N); - Rewrite (N, - Make_Real_Literal (Sloc (N), - Realval => Small_Value (Typ) * Cint)); - - Set_Is_Static_Expression (N, Stat); - end if; - - -- In all cases, set the corresponding integer field - - Set_Corresponding_Integer_Value (N, Cint); - end; - end if; - - -- Now replace the actual type by the expected type as usual - - Set_Etype (N, Typ); - Eval_Real_Literal (N); - end Resolve_Real_Literal; - - ----------------------- - -- Resolve_Reference -- - ----------------------- - - procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id) is - P : constant Node_Id := Prefix (N); - - begin - -- Replace general access with specific type - - if Ekind (Etype (N)) = E_Allocator_Type then - Set_Etype (N, Base_Type (Typ)); - end if; - - Resolve (P, Designated_Type (Etype (N))); - - -- If we are taking the reference of a volatile entity, then treat - -- it as a potential modification of this entity. This is much too - -- conservative, but is necessary because remove side effects can - -- result in transformations of normal assignments into reference - -- sequences that otherwise fail to notice the modification. - - if Is_Entity_Name (P) and then Treat_As_Volatile (Entity (P)) then - Note_Possible_Modification (P, Sure => False); - end if; - end Resolve_Reference; - - -------------------------------- - -- Resolve_Selected_Component -- - -------------------------------- - - procedure Resolve_Selected_Component (N : Node_Id; Typ : Entity_Id) is - Comp : Entity_Id; - Comp1 : Entity_Id := Empty; -- prevent junk warning - P : constant Node_Id := Prefix (N); - S : constant Node_Id := Selector_Name (N); - T : Entity_Id := Etype (P); - I : Interp_Index; - I1 : Interp_Index := 0; -- prevent junk warning - It : Interp; - It1 : Interp; - Found : Boolean; - - function Init_Component return Boolean; - -- Check whether this is the initialization of a component within an - -- init proc (by assignment or call to another init proc). If true, - -- there is no need for a discriminant check. - - -------------------- - -- Init_Component -- - -------------------- - - function Init_Component return Boolean is - begin - return Inside_Init_Proc - and then Nkind (Prefix (N)) = N_Identifier - and then Chars (Prefix (N)) = Name_uInit - and then Nkind (Parent (Parent (N))) = N_Case_Statement_Alternative; - end Init_Component; - - -- Start of processing for Resolve_Selected_Component - - begin - if Is_Overloaded (P) then - - -- Use the context type to select the prefix that has a selector - -- of the correct name and type. - - Found := False; - Get_First_Interp (P, I, It); - - Search : while Present (It.Typ) loop - if Is_Access_Type (It.Typ) then - T := Designated_Type (It.Typ); - else - T := It.Typ; - end if; - - if Is_Record_Type (T) then - - -- The visible components of a class-wide type are those of - -- the root type. - - if Is_Class_Wide_Type (T) then - T := Etype (T); - end if; - - Comp := First_Entity (T); - while Present (Comp) loop - if Chars (Comp) = Chars (S) - and then Covers (Etype (Comp), Typ) - then - if not Found then - Found := True; - I1 := I; - It1 := It; - Comp1 := Comp; - - else - It := Disambiguate (P, I1, I, Any_Type); - - if It = No_Interp then - Error_Msg_N - ("ambiguous prefix for selected component", N); - Set_Etype (N, Typ); - return; - - else - It1 := It; - - -- There may be an implicit dereference. Retrieve - -- designated record type. - - if Is_Access_Type (It1.Typ) then - T := Designated_Type (It1.Typ); - else - T := It1.Typ; - end if; - - if Scope (Comp1) /= T then - - -- Resolution chooses the new interpretation. - -- Find the component with the right name. - - Comp1 := First_Entity (T); - while Present (Comp1) - and then Chars (Comp1) /= Chars (S) - loop - Comp1 := Next_Entity (Comp1); - end loop; - end if; - - exit Search; - end if; - end if; - end if; - - Comp := Next_Entity (Comp); - end loop; - - end if; - - Get_Next_Interp (I, It); - end loop Search; - - Resolve (P, It1.Typ); - Set_Etype (N, Typ); - Set_Entity_With_Style_Check (S, Comp1); - - else - -- Resolve prefix with its type - - Resolve (P, T); - end if; - - -- Generate cross-reference. We needed to wait until full overloading - -- resolution was complete to do this, since otherwise we can't tell if - -- we are an Lvalue of not. - - if May_Be_Lvalue (N) then - Generate_Reference (Entity (S), S, 'm'); - else - Generate_Reference (Entity (S), S, 'r'); - end if; - - -- If prefix is an access type, the node will be transformed into an - -- explicit dereference during expansion. The type of the node is the - -- designated type of that of the prefix. - - if Is_Access_Type (Etype (P)) then - T := Designated_Type (Etype (P)); - Check_Fully_Declared_Prefix (T, P); - else - T := Etype (P); - end if; - - if Has_Discriminants (T) - and then (Ekind (Entity (S)) = E_Component - or else - Ekind (Entity (S)) = E_Discriminant) - and then Present (Original_Record_Component (Entity (S))) - and then Ekind (Original_Record_Component (Entity (S))) = E_Component - and then Present (Discriminant_Checking_Func - (Original_Record_Component (Entity (S)))) - and then not Discriminant_Checks_Suppressed (T) - and then not Init_Component - then - Set_Do_Discriminant_Check (N); - end if; - - if Ekind (Entity (S)) = E_Void then - Error_Msg_N ("premature use of component", S); - end if; - - -- If the prefix is a record conversion, this may be a renamed - -- discriminant whose bounds differ from those of the original - -- one, so we must ensure that a range check is performed. - - if Nkind (P) = N_Type_Conversion - and then Ekind (Entity (S)) = E_Discriminant - and then Is_Discrete_Type (Typ) - then - Set_Etype (N, Base_Type (Typ)); - end if; - - -- Note: No Eval processing is required, because the prefix is of a - -- record type, or protected type, and neither can possibly be static. - - end Resolve_Selected_Component; - - ------------------- - -- Resolve_Shift -- - ------------------- - - procedure Resolve_Shift (N : Node_Id; Typ : Entity_Id) is - B_Typ : constant Entity_Id := Base_Type (Typ); - L : constant Node_Id := Left_Opnd (N); - R : constant Node_Id := Right_Opnd (N); - - begin - -- We do the resolution using the base type, because intermediate values - -- in expressions always are of the base type, not a subtype of it. - - Resolve (L, B_Typ); - Resolve (R, Standard_Natural); - - Check_Unset_Reference (L); - Check_Unset_Reference (R); - - Set_Etype (N, B_Typ); - Generate_Operator_Reference (N, B_Typ); - Eval_Shift (N); - end Resolve_Shift; - - --------------------------- - -- Resolve_Short_Circuit -- - --------------------------- - - procedure Resolve_Short_Circuit (N : Node_Id; Typ : Entity_Id) is - B_Typ : constant Entity_Id := Base_Type (Typ); - L : constant Node_Id := Left_Opnd (N); - R : constant Node_Id := Right_Opnd (N); - - begin - Resolve (L, B_Typ); - Resolve (R, B_Typ); - - -- Check for issuing warning for always False assert/check, this happens - -- when assertions are turned off, in which case the pragma Assert/Check - -- was transformed into: - - -- if False and then <condition> then ... - - -- and we detect this pattern - - if Warn_On_Assertion_Failure - and then Is_Entity_Name (R) - and then Entity (R) = Standard_False - and then Nkind (Parent (N)) = N_If_Statement - and then Nkind (N) = N_And_Then - and then Is_Entity_Name (L) - and then Entity (L) = Standard_False - then - declare - Orig : constant Node_Id := Original_Node (Parent (N)); - - begin - if Nkind (Orig) = N_Pragma - and then Pragma_Name (Orig) = Name_Assert - then - -- Don't want to warn if original condition is explicit False - - declare - Expr : constant Node_Id := - Original_Node - (Expression - (First (Pragma_Argument_Associations (Orig)))); - begin - if Is_Entity_Name (Expr) - and then Entity (Expr) = Standard_False - then - null; - else - -- Issue warning. Note that we don't want to make this - -- an unconditional warning, because if the assert is - -- within deleted code we do not want the warning. But - -- we do not want the deletion of the IF/AND-THEN to - -- take this message with it. We achieve this by making - -- sure that the expanded code points to the Sloc of - -- the expression, not the original pragma. - - Error_Msg_N ("?assertion would fail at run-time", Orig); - end if; - end; - - -- Similar processing for Check pragma - - elsif Nkind (Orig) = N_Pragma - and then Pragma_Name (Orig) = Name_Check - then - -- Don't want to warn if original condition is explicit False - - declare - Expr : constant Node_Id := - Original_Node - (Expression - (Next (First - (Pragma_Argument_Associations (Orig))))); - begin - if Is_Entity_Name (Expr) - and then Entity (Expr) = Standard_False - then - null; - else - Error_Msg_N ("?check would fail at run-time", Orig); - end if; - end; - end if; - end; - end if; - - -- Continue with processing of short circuit - - Check_Unset_Reference (L); - Check_Unset_Reference (R); - - Set_Etype (N, B_Typ); - Eval_Short_Circuit (N); - end Resolve_Short_Circuit; - - ------------------- - -- Resolve_Slice -- - ------------------- - - procedure Resolve_Slice (N : Node_Id; Typ : Entity_Id) is - Name : constant Node_Id := Prefix (N); - Drange : constant Node_Id := Discrete_Range (N); - Array_Type : Entity_Id := Empty; - Index : Node_Id; - - begin - if Is_Overloaded (Name) then - - -- Use the context type to select the prefix that yields the - -- correct array type. - - declare - I : Interp_Index; - I1 : Interp_Index := 0; - It : Interp; - P : constant Node_Id := Prefix (N); - Found : Boolean := False; - - begin - Get_First_Interp (P, I, It); - while Present (It.Typ) loop - if (Is_Array_Type (It.Typ) - and then Covers (Typ, It.Typ)) - or else (Is_Access_Type (It.Typ) - and then Is_Array_Type (Designated_Type (It.Typ)) - and then Covers (Typ, Designated_Type (It.Typ))) - then - if Found then - It := Disambiguate (P, I1, I, Any_Type); - - if It = No_Interp then - Error_Msg_N ("ambiguous prefix for slicing", N); - Set_Etype (N, Typ); - return; - else - Found := True; - Array_Type := It.Typ; - I1 := I; - end if; - else - Found := True; - Array_Type := It.Typ; - I1 := I; - end if; - end if; - - Get_Next_Interp (I, It); - end loop; - end; - - else - Array_Type := Etype (Name); - end if; - - Resolve (Name, Array_Type); - - if Is_Access_Type (Array_Type) then - Apply_Access_Check (N); - Array_Type := Designated_Type (Array_Type); - - -- If the prefix is an access to an unconstrained array, we must use - -- the actual subtype of the object to perform the index checks. The - -- object denoted by the prefix is implicit in the node, so we build - -- an explicit representation for it in order to compute the actual - -- subtype. - - if not Is_Constrained (Array_Type) then - Remove_Side_Effects (Prefix (N)); - - declare - Obj : constant Node_Id := - Make_Explicit_Dereference (Sloc (N), - Prefix => New_Copy_Tree (Prefix (N))); - begin - Set_Etype (Obj, Array_Type); - Set_Parent (Obj, Parent (N)); - Array_Type := Get_Actual_Subtype (Obj); - end; - end if; - - elsif Is_Entity_Name (Name) - or else (Nkind (Name) = N_Function_Call - and then not Is_Constrained (Etype (Name))) - then - Array_Type := Get_Actual_Subtype (Name); - - -- If the name is a selected component that depends on discriminants, - -- build an actual subtype for it. This can happen only when the name - -- itself is overloaded; otherwise the actual subtype is created when - -- the selected component is analyzed. - - elsif Nkind (Name) = N_Selected_Component - and then Full_Analysis - and then Depends_On_Discriminant (First_Index (Array_Type)) - then - declare - Act_Decl : constant Node_Id := - Build_Actual_Subtype_Of_Component (Array_Type, Name); - begin - Insert_Action (N, Act_Decl); - Array_Type := Defining_Identifier (Act_Decl); - end; - end if; - - -- If name was overloaded, set slice type correctly now - - Set_Etype (N, Array_Type); - - -- If the range is specified by a subtype mark, no resolution is - -- necessary. Else resolve the bounds, and apply needed checks. - - if not Is_Entity_Name (Drange) then - Index := First_Index (Array_Type); - Resolve (Drange, Base_Type (Etype (Index))); - - if Nkind (Drange) = N_Range - - -- Do not apply the range check to nodes associated with the - -- frontend expansion of the dispatch table. We first check - -- if Ada.Tags is already loaded to void the addition of an - -- undesired dependence on such run-time unit. - - and then - (VM_Target /= No_VM - or else not - (RTU_Loaded (Ada_Tags) - and then Nkind (Prefix (N)) = N_Selected_Component - and then Present (Entity (Selector_Name (Prefix (N)))) - and then Entity (Selector_Name (Prefix (N))) = - RTE_Record_Component (RE_Prims_Ptr))) - then - Apply_Range_Check (Drange, Etype (Index)); - end if; - end if; - - Set_Slice_Subtype (N); - - if Nkind (Drange) = N_Range then - Warn_On_Suspicious_Index (Name, Low_Bound (Drange)); - Warn_On_Suspicious_Index (Name, High_Bound (Drange)); - end if; - - Eval_Slice (N); - end Resolve_Slice; - - ---------------------------- - -- Resolve_String_Literal -- - ---------------------------- - - procedure Resolve_String_Literal (N : Node_Id; Typ : Entity_Id) is - C_Typ : constant Entity_Id := Component_Type (Typ); - R_Typ : constant Entity_Id := Root_Type (C_Typ); - Loc : constant Source_Ptr := Sloc (N); - Str : constant String_Id := Strval (N); - Strlen : constant Nat := String_Length (Str); - Subtype_Id : Entity_Id; - Need_Check : Boolean; - - begin - -- For a string appearing in a concatenation, defer creation of the - -- string_literal_subtype until the end of the resolution of the - -- concatenation, because the literal may be constant-folded away. This - -- is a useful optimization for long concatenation expressions. - - -- If the string is an aggregate built for a single character (which - -- happens in a non-static context) or a is null string to which special - -- checks may apply, we build the subtype. Wide strings must also get a - -- string subtype if they come from a one character aggregate. Strings - -- generated by attributes might be static, but it is often hard to - -- determine whether the enclosing context is static, so we generate - -- subtypes for them as well, thus losing some rarer optimizations ??? - -- Same for strings that come from a static conversion. - - Need_Check := - (Strlen = 0 and then Typ /= Standard_String) - or else Nkind (Parent (N)) /= N_Op_Concat - or else (N /= Left_Opnd (Parent (N)) - and then N /= Right_Opnd (Parent (N))) - or else ((Typ = Standard_Wide_String - or else Typ = Standard_Wide_Wide_String) - and then Nkind (Original_Node (N)) /= N_String_Literal); - - -- If the resolving type is itself a string literal subtype, we - -- can just reuse it, since there is no point in creating another. - - if Ekind (Typ) = E_String_Literal_Subtype then - Subtype_Id := Typ; - - elsif Nkind (Parent (N)) = N_Op_Concat - and then not Need_Check - and then not Nkind_In (Original_Node (N), N_Character_Literal, - N_Attribute_Reference, - N_Qualified_Expression, - N_Type_Conversion) - then - Subtype_Id := Typ; - - -- Otherwise we must create a string literal subtype. Note that the - -- whole idea of string literal subtypes is simply to avoid the need - -- for building a full fledged array subtype for each literal. - - else - Set_String_Literal_Subtype (N, Typ); - Subtype_Id := Etype (N); - end if; - - if Nkind (Parent (N)) /= N_Op_Concat - or else Need_Check - then - Set_Etype (N, Subtype_Id); - Eval_String_Literal (N); - end if; - - if Is_Limited_Composite (Typ) - or else Is_Private_Composite (Typ) - then - Error_Msg_N ("string literal not available for private array", N); - Set_Etype (N, Any_Type); - return; - end if; - - -- The validity of a null string has been checked in the - -- call to Eval_String_Literal. - - if Strlen = 0 then - return; - - -- Always accept string literal with component type Any_Character, which - -- occurs in error situations and in comparisons of literals, both of - -- which should accept all literals. - - elsif R_Typ = Any_Character then - return; - - -- If the type is bit-packed, then we always transform the string - -- literal into a full fledged aggregate. - - elsif Is_Bit_Packed_Array (Typ) then - null; - - -- Deal with cases of Wide_Wide_String, Wide_String, and String - - else - -- For Standard.Wide_Wide_String, or any other type whose component - -- type is Standard.Wide_Wide_Character, we know that all the - -- characters in the string must be acceptable, since the parser - -- accepted the characters as valid character literals. - - if R_Typ = Standard_Wide_Wide_Character then - null; - - -- For the case of Standard.String, or any other type whose component - -- type is Standard.Character, we must make sure that there are no - -- wide characters in the string, i.e. that it is entirely composed - -- of characters in range of type Character. - - -- If the string literal is the result of a static concatenation, the - -- test has already been performed on the components, and need not be - -- repeated. - - elsif R_Typ = Standard_Character - and then Nkind (Original_Node (N)) /= N_Op_Concat - then - for J in 1 .. Strlen loop - if not In_Character_Range (Get_String_Char (Str, J)) then - - -- If we are out of range, post error. This is one of the - -- very few places that we place the flag in the middle of - -- a token, right under the offending wide character. - - Error_Msg - ("literal out of range of type Standard.Character", - Source_Ptr (Int (Loc) + J)); - return; - end if; - end loop; - - -- For the case of Standard.Wide_String, or any other type whose - -- component type is Standard.Wide_Character, we must make sure that - -- there are no wide characters in the string, i.e. that it is - -- entirely composed of characters in range of type Wide_Character. - - -- If the string literal is the result of a static concatenation, - -- the test has already been performed on the components, and need - -- not be repeated. - - elsif R_Typ = Standard_Wide_Character - and then Nkind (Original_Node (N)) /= N_Op_Concat - then - for J in 1 .. Strlen loop - if not In_Wide_Character_Range (Get_String_Char (Str, J)) then - - -- If we are out of range, post error. This is one of the - -- very few places that we place the flag in the middle of - -- a token, right under the offending wide character. - - -- This is not quite right, because characters in general - -- will take more than one character position ??? - - Error_Msg - ("literal out of range of type Standard.Wide_Character", - Source_Ptr (Int (Loc) + J)); - return; - end if; - end loop; - - -- If the root type is not a standard character, then we will convert - -- the string into an aggregate and will let the aggregate code do - -- the checking. Standard Wide_Wide_Character is also OK here. - - else - null; - end if; - - -- See if the component type of the array corresponding to the string - -- has compile time known bounds. If yes we can directly check - -- whether the evaluation of the string will raise constraint error. - -- Otherwise we need to transform the string literal into the - -- corresponding character aggregate and let the aggregate - -- code do the checking. - - if Is_Standard_Character_Type (R_Typ) then - - -- Check for the case of full range, where we are definitely OK - - if Component_Type (Typ) = Base_Type (Component_Type (Typ)) then - return; - end if; - - -- Here the range is not the complete base type range, so check - - declare - Comp_Typ_Lo : constant Node_Id := - Type_Low_Bound (Component_Type (Typ)); - Comp_Typ_Hi : constant Node_Id := - Type_High_Bound (Component_Type (Typ)); - - Char_Val : Uint; - - begin - if Compile_Time_Known_Value (Comp_Typ_Lo) - and then Compile_Time_Known_Value (Comp_Typ_Hi) - then - for J in 1 .. Strlen loop - Char_Val := UI_From_Int (Int (Get_String_Char (Str, J))); - - if Char_Val < Expr_Value (Comp_Typ_Lo) - or else Char_Val > Expr_Value (Comp_Typ_Hi) - then - Apply_Compile_Time_Constraint_Error - (N, "character out of range?", CE_Range_Check_Failed, - Loc => Source_Ptr (Int (Loc) + J)); - end if; - end loop; - - return; - end if; - end; - end if; - end if; - - -- If we got here we meed to transform the string literal into the - -- equivalent qualified positional array aggregate. This is rather - -- heavy artillery for this situation, but it is hard work to avoid. - - declare - Lits : constant List_Id := New_List; - P : Source_Ptr := Loc + 1; - C : Char_Code; - - begin - -- Build the character literals, we give them source locations that - -- correspond to the string positions, which is a bit tricky given - -- the possible presence of wide character escape sequences. - - for J in 1 .. Strlen loop - C := Get_String_Char (Str, J); - Set_Character_Literal_Name (C); - - Append_To (Lits, - Make_Character_Literal (P, - Chars => Name_Find, - Char_Literal_Value => UI_From_CC (C))); - - if In_Character_Range (C) then - P := P + 1; - - -- Should we have a call to Skip_Wide here ??? - -- ??? else - -- Skip_Wide (P); - - end if; - end loop; - - Rewrite (N, - Make_Qualified_Expression (Loc, - Subtype_Mark => New_Reference_To (Typ, Loc), - Expression => - Make_Aggregate (Loc, Expressions => Lits))); - - Analyze_And_Resolve (N, Typ); - end; - end Resolve_String_Literal; - - ----------------------------- - -- Resolve_Subprogram_Info -- - ----------------------------- - - procedure Resolve_Subprogram_Info (N : Node_Id; Typ : Entity_Id) is - begin - Set_Etype (N, Typ); - end Resolve_Subprogram_Info; - - ----------------------------- - -- Resolve_Type_Conversion -- - ----------------------------- - - procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id) is - Conv_OK : constant Boolean := Conversion_OK (N); - Operand : constant Node_Id := Expression (N); - Operand_Typ : constant Entity_Id := Etype (Operand); - Target_Typ : constant Entity_Id := Etype (N); - Rop : Node_Id; - Orig_N : Node_Id; - Orig_T : Node_Id; - - begin - if not Conv_OK - and then not Valid_Conversion (N, Target_Typ, Operand) - then - return; - end if; - - if Etype (Operand) = Any_Fixed then - - -- Mixed-mode operation involving a literal. Context must be a fixed - -- type which is applied to the literal subsequently. - - if Is_Fixed_Point_Type (Typ) then - Set_Etype (Operand, Universal_Real); - - elsif Is_Numeric_Type (Typ) - and then Nkind_In (Operand, N_Op_Multiply, N_Op_Divide) - and then (Etype (Right_Opnd (Operand)) = Universal_Real - or else - Etype (Left_Opnd (Operand)) = Universal_Real) - then - -- Return if expression is ambiguous - - if Unique_Fixed_Point_Type (N) = Any_Type then - return; - - -- If nothing else, the available fixed type is Duration - - else - Set_Etype (Operand, Standard_Duration); - end if; - - -- Resolve the real operand with largest available precision - - if Etype (Right_Opnd (Operand)) = Universal_Real then - Rop := New_Copy_Tree (Right_Opnd (Operand)); - else - Rop := New_Copy_Tree (Left_Opnd (Operand)); - end if; - - Resolve (Rop, Universal_Real); - - -- If the operand is a literal (it could be a non-static and - -- illegal exponentiation) check whether the use of Duration - -- is potentially inaccurate. - - if Nkind (Rop) = N_Real_Literal - and then Realval (Rop) /= Ureal_0 - and then abs (Realval (Rop)) < Delta_Value (Standard_Duration) - then - Error_Msg_N - ("?universal real operand can only " & - "be interpreted as Duration!", - Rop); - Error_Msg_N - ("\?precision will be lost in the conversion!", Rop); - end if; - - elsif Is_Numeric_Type (Typ) - and then Nkind (Operand) in N_Op - and then Unique_Fixed_Point_Type (N) /= Any_Type - then - Set_Etype (Operand, Standard_Duration); - - else - Error_Msg_N ("invalid context for mixed mode operation", N); - Set_Etype (Operand, Any_Type); - return; - end if; - end if; - - Resolve (Operand); - - -- Note: we do the Eval_Type_Conversion call before applying the - -- required checks for a subtype conversion. This is important, - -- since both are prepared under certain circumstances to change - -- the type conversion to a constraint error node, but in the case - -- of Eval_Type_Conversion this may reflect an illegality in the - -- static case, and we would miss the illegality (getting only a - -- warning message), if we applied the type conversion checks first. - - Eval_Type_Conversion (N); - - -- Even when evaluation is not possible, we may be able to simplify - -- the conversion or its expression. This needs to be done before - -- applying checks, since otherwise the checks may use the original - -- expression and defeat the simplifications. This is specifically - -- the case for elimination of the floating-point Truncation - -- attribute in float-to-int conversions. - - Simplify_Type_Conversion (N); - - -- If after evaluation we still have a type conversion, then we - -- may need to apply checks required for a subtype conversion. - - -- Skip these type conversion checks if universal fixed operands - -- operands involved, since range checks are handled separately for - -- these cases (in the appropriate Expand routines in unit Exp_Fixd). - - if Nkind (N) = N_Type_Conversion - and then not Is_Generic_Type (Root_Type (Target_Typ)) - and then Target_Typ /= Universal_Fixed - and then Operand_Typ /= Universal_Fixed - then - Apply_Type_Conversion_Checks (N); - end if; - - -- Issue warning for conversion of simple object to its own type - -- We have to test the original nodes, since they may have been - -- rewritten by various optimizations. - - Orig_N := Original_Node (N); - - if Warn_On_Redundant_Constructs - and then Comes_From_Source (Orig_N) - and then Nkind (Orig_N) = N_Type_Conversion - and then not In_Instance - then - Orig_N := Original_Node (Expression (Orig_N)); - Orig_T := Target_Typ; - - -- If the node is part of a larger expression, the Target_Type - -- may not be the original type of the node if the context is a - -- condition. Recover original type to see if conversion is needed. - - if Is_Boolean_Type (Orig_T) - and then Nkind (Parent (N)) in N_Op - then - Orig_T := Etype (Parent (N)); - end if; - - if Is_Entity_Name (Orig_N) - and then - (Etype (Entity (Orig_N)) = Orig_T - or else - (Ekind (Entity (Orig_N)) = E_Loop_Parameter - and then Covers (Orig_T, Etype (Entity (Orig_N))))) - then - Error_Msg_Node_2 := Orig_T; - Error_Msg_NE - ("?redundant conversion, & is of type &!", N, Entity (Orig_N)); - end if; - end if; - - -- Ada 2005 (AI-251): Handle class-wide interface type conversions. - -- No need to perform any interface conversion if the type of the - -- expression coincides with the target type. - - if Ada_Version >= Ada_05 - and then Expander_Active - and then Operand_Typ /= Target_Typ - then - declare - Opnd : Entity_Id := Operand_Typ; - Target : Entity_Id := Target_Typ; - - begin - if Is_Access_Type (Opnd) then - Opnd := Directly_Designated_Type (Opnd); - end if; - - if Is_Access_Type (Target_Typ) then - Target := Directly_Designated_Type (Target); - end if; - - if Opnd = Target then - null; - - -- Conversion from interface type - - elsif Is_Interface (Opnd) then - - -- Ada 2005 (AI-217): Handle entities from limited views - - if From_With_Type (Opnd) then - Error_Msg_Qual_Level := 99; - Error_Msg_NE ("missing with-clause on package &", N, - Cunit_Entity (Get_Source_Unit (Base_Type (Opnd)))); - Error_Msg_N - ("type conversions require visibility of the full view", - N); - - elsif From_With_Type (Target) - and then not - (Is_Access_Type (Target_Typ) - and then Present (Non_Limited_View (Etype (Target)))) - then - Error_Msg_Qual_Level := 99; - Error_Msg_NE ("missing with-clause on package &", N, - Cunit_Entity (Get_Source_Unit (Base_Type (Target)))); - Error_Msg_N - ("type conversions require visibility of the full view", - N); - - else - Expand_Interface_Conversion (N, Is_Static => False); - end if; - - -- Conversion to interface type - - elsif Is_Interface (Target) then - - -- Handle subtypes - - if Ekind (Opnd) = E_Protected_Subtype - or else Ekind (Opnd) = E_Task_Subtype - then - Opnd := Etype (Opnd); - end if; - - if not Interface_Present_In_Ancestor - (Typ => Opnd, - Iface => Target) - then - if Is_Class_Wide_Type (Opnd) then - - -- The static analysis is not enough to know if the - -- interface is implemented or not. Hence we must pass - -- the work to the expander to generate code to evaluate - -- the conversion at run-time. - - Expand_Interface_Conversion (N, Is_Static => False); - - else - Error_Msg_Name_1 := Chars (Etype (Target)); - Error_Msg_Name_2 := Chars (Opnd); - Error_Msg_N - ("wrong interface conversion (% is not a progenitor " & - "of %)", N); - end if; - - else - Expand_Interface_Conversion (N); - end if; - end if; - end; - end if; - end Resolve_Type_Conversion; - - ---------------------- - -- Resolve_Unary_Op -- - ---------------------- - - procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id) is - B_Typ : constant Entity_Id := Base_Type (Typ); - R : constant Node_Id := Right_Opnd (N); - OK : Boolean; - Lo : Uint; - Hi : Uint; - - begin - -- Deal with intrinsic unary operators - - if Comes_From_Source (N) - and then Ekind (Entity (N)) = E_Function - and then Is_Imported (Entity (N)) - and then Is_Intrinsic_Subprogram (Entity (N)) - then - Resolve_Intrinsic_Unary_Operator (N, Typ); - return; - end if; - - -- Deal with universal cases - - if Etype (R) = Universal_Integer - or else - Etype (R) = Universal_Real - then - Check_For_Visible_Operator (N, B_Typ); - end if; - - Set_Etype (N, B_Typ); - Resolve (R, B_Typ); - - -- Generate warning for expressions like abs (x mod 2) - - if Warn_On_Redundant_Constructs - and then Nkind (N) = N_Op_Abs - then - Determine_Range (Right_Opnd (N), OK, Lo, Hi); - - if OK and then Hi >= Lo and then Lo >= 0 then - Error_Msg_N - ("?abs applied to known non-negative value has no effect", N); - end if; - end if; - - -- Deal with reference generation - - Check_Unset_Reference (R); - Generate_Operator_Reference (N, B_Typ); - Eval_Unary_Op (N); - - -- Set overflow checking bit. Much cleverer code needed here eventually - -- and perhaps the Resolve routines should be separated for the various - -- arithmetic operations, since they will need different processing ??? - - if Nkind (N) in N_Op then - if not Overflow_Checks_Suppressed (Etype (N)) then - Enable_Overflow_Check (N); - end if; - end if; - - -- Generate warning for expressions like -5 mod 3 for integers. No - -- need to worry in the floating-point case, since parens do not affect - -- the result so there is no point in giving in a warning. - - declare - Norig : constant Node_Id := Original_Node (N); - Rorig : Node_Id; - Val : Uint; - HB : Uint; - LB : Uint; - Lval : Uint; - Opnd : Node_Id; - - begin - if Warn_On_Questionable_Missing_Parens - and then Comes_From_Source (Norig) - and then Is_Integer_Type (Typ) - and then Nkind (Norig) = N_Op_Minus - then - Rorig := Original_Node (Right_Opnd (Norig)); - - -- We are looking for cases where the right operand is not - -- parenthesized, and is a binary operator, multiply, divide, or - -- mod. These are the cases where the grouping can affect results. - - if Paren_Count (Rorig) = 0 - and then Nkind_In (Rorig, N_Op_Mod, N_Op_Multiply, N_Op_Divide) - then - -- For mod, we always give the warning, since the value is - -- affected by the parenthesization (e.g. (-5) mod 315 /= - -- (5 mod 315)). But for the other cases, the only concern is - -- overflow, e.g. for the case of 8 big signed (-(2 * 64) - -- overflows, but (-2) * 64 does not). So we try to give the - -- message only when overflow is possible. - - if Nkind (Rorig) /= N_Op_Mod - and then Compile_Time_Known_Value (R) - then - Val := Expr_Value (R); - - if Compile_Time_Known_Value (Type_High_Bound (Typ)) then - HB := Expr_Value (Type_High_Bound (Typ)); - else - HB := Expr_Value (Type_High_Bound (Base_Type (Typ))); - end if; - - if Compile_Time_Known_Value (Type_Low_Bound (Typ)) then - LB := Expr_Value (Type_Low_Bound (Typ)); - else - LB := Expr_Value (Type_Low_Bound (Base_Type (Typ))); - end if; - - -- Note that the test below is deliberately excluding - -- the largest negative number, since that is a potentially - -- troublesome case (e.g. -2 * x, where the result is the - -- largest negative integer has an overflow with 2 * x). - - if Val > LB and then Val <= HB then - return; - end if; - end if; - - -- For the multiplication case, the only case we have to worry - -- about is when (-a)*b is exactly the largest negative number - -- so that -(a*b) can cause overflow. This can only happen if - -- a is a power of 2, and more generally if any operand is a - -- constant that is not a power of 2, then the parentheses - -- cannot affect whether overflow occurs. We only bother to - -- test the left most operand - - -- Loop looking at left operands for one that has known value - - Opnd := Rorig; - Opnd_Loop : while Nkind (Opnd) = N_Op_Multiply loop - if Compile_Time_Known_Value (Left_Opnd (Opnd)) then - Lval := UI_Abs (Expr_Value (Left_Opnd (Opnd))); - - -- Operand value of 0 or 1 skips warning - - if Lval <= 1 then - return; - - -- Otherwise check power of 2, if power of 2, warn, if - -- anything else, skip warning. - - else - while Lval /= 2 loop - if Lval mod 2 = 1 then - return; - else - Lval := Lval / 2; - end if; - end loop; - - exit Opnd_Loop; - end if; - end if; - - -- Keep looking at left operands - - Opnd := Left_Opnd (Opnd); - end loop Opnd_Loop; - - -- For rem or "/" we can only have a problematic situation - -- if the divisor has a value of minus one or one. Otherwise - -- overflow is impossible (divisor > 1) or we have a case of - -- division by zero in any case. - - if Nkind_In (Rorig, N_Op_Divide, N_Op_Rem) - and then Compile_Time_Known_Value (Right_Opnd (Rorig)) - and then UI_Abs (Expr_Value (Right_Opnd (Rorig))) /= 1 - then - return; - end if; - - -- If we fall through warning should be issued - - Error_Msg_N - ("?unary minus expression should be parenthesized here!", N); - end if; - end if; - end; - end Resolve_Unary_Op; - - ---------------------------------- - -- Resolve_Unchecked_Expression -- - ---------------------------------- - - procedure Resolve_Unchecked_Expression - (N : Node_Id; - Typ : Entity_Id) - is - begin - Resolve (Expression (N), Typ, Suppress => All_Checks); - Set_Etype (N, Typ); - end Resolve_Unchecked_Expression; - - --------------------------------------- - -- Resolve_Unchecked_Type_Conversion -- - --------------------------------------- - - procedure Resolve_Unchecked_Type_Conversion - (N : Node_Id; - Typ : Entity_Id) - is - pragma Warnings (Off, Typ); - - Operand : constant Node_Id := Expression (N); - Opnd_Type : constant Entity_Id := Etype (Operand); - - begin - -- Resolve operand using its own type - - Resolve (Operand, Opnd_Type); - Eval_Unchecked_Conversion (N); - - end Resolve_Unchecked_Type_Conversion; - - ------------------------------ - -- Rewrite_Operator_As_Call -- - ------------------------------ - - procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id) is - Loc : constant Source_Ptr := Sloc (N); - Actuals : constant List_Id := New_List; - New_N : Node_Id; - - begin - if Nkind (N) in N_Binary_Op then - Append (Left_Opnd (N), Actuals); - end if; - - Append (Right_Opnd (N), Actuals); - - New_N := - Make_Function_Call (Sloc => Loc, - Name => New_Occurrence_Of (Nam, Loc), - Parameter_Associations => Actuals); - - Preserve_Comes_From_Source (New_N, N); - Preserve_Comes_From_Source (Name (New_N), N); - Rewrite (N, New_N); - Set_Etype (N, Etype (Nam)); - end Rewrite_Operator_As_Call; - - ------------------------------ - -- Rewrite_Renamed_Operator -- - ------------------------------ - - procedure Rewrite_Renamed_Operator - (N : Node_Id; - Op : Entity_Id; - Typ : Entity_Id) - is - Nam : constant Name_Id := Chars (Op); - Is_Binary : constant Boolean := Nkind (N) in N_Binary_Op; - Op_Node : Node_Id; - - begin - -- Rewrite the operator node using the real operator, not its - -- renaming. Exclude user-defined intrinsic operations of the same - -- name, which are treated separately and rewritten as calls. - - if Ekind (Op) /= E_Function - or else Chars (N) /= Nam - then - Op_Node := New_Node (Operator_Kind (Nam, Is_Binary), Sloc (N)); - Set_Chars (Op_Node, Nam); - Set_Etype (Op_Node, Etype (N)); - Set_Entity (Op_Node, Op); - Set_Right_Opnd (Op_Node, Right_Opnd (N)); - - -- Indicate that both the original entity and its renaming are - -- referenced at this point. - - Generate_Reference (Entity (N), N); - Generate_Reference (Op, N); - - if Is_Binary then - Set_Left_Opnd (Op_Node, Left_Opnd (N)); - end if; - - Rewrite (N, Op_Node); - - -- If the context type is private, add the appropriate conversions - -- so that the operator is applied to the full view. This is done - -- in the routines that resolve intrinsic operators, - - if Is_Intrinsic_Subprogram (Op) - and then Is_Private_Type (Typ) - then - case Nkind (N) is - when N_Op_Add | N_Op_Subtract | N_Op_Multiply | N_Op_Divide | - N_Op_Expon | N_Op_Mod | N_Op_Rem => - Resolve_Intrinsic_Operator (N, Typ); - - when N_Op_Plus | N_Op_Minus | N_Op_Abs => - Resolve_Intrinsic_Unary_Operator (N, Typ); - - when others => - Resolve (N, Typ); - end case; - end if; - - elsif Ekind (Op) = E_Function - and then Is_Intrinsic_Subprogram (Op) - then - -- Operator renames a user-defined operator of the same name. Use - -- the original operator in the node, which is the one that Gigi - -- knows about. - - Set_Entity (N, Op); - Set_Is_Overloaded (N, False); - end if; - end Rewrite_Renamed_Operator; - - ----------------------- - -- Set_Slice_Subtype -- - ----------------------- - - -- Build an implicit subtype declaration to represent the type delivered - -- by the slice. This is an abbreviated version of an array subtype. We - -- define an index subtype for the slice, using either the subtype name - -- or the discrete range of the slice. To be consistent with index usage - -- elsewhere, we create a list header to hold the single index. This list - -- is not otherwise attached to the syntax tree. - - procedure Set_Slice_Subtype (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Index_List : constant List_Id := New_List; - Index : Node_Id; - Index_Subtype : Entity_Id; - Index_Type : Entity_Id; - Slice_Subtype : Entity_Id; - Drange : constant Node_Id := Discrete_Range (N); - - begin - if Is_Entity_Name (Drange) then - Index_Subtype := Entity (Drange); - - else - -- We force the evaluation of a range. This is definitely needed in - -- the renamed case, and seems safer to do unconditionally. Note in - -- any case that since we will create and insert an Itype referring - -- to this range, we must make sure any side effect removal actions - -- are inserted before the Itype definition. - - if Nkind (Drange) = N_Range then - Force_Evaluation (Low_Bound (Drange)); - Force_Evaluation (High_Bound (Drange)); - end if; - - Index_Type := Base_Type (Etype (Drange)); - - Index_Subtype := Create_Itype (Subtype_Kind (Ekind (Index_Type)), N); - - Set_Scalar_Range (Index_Subtype, Drange); - Set_Etype (Index_Subtype, Index_Type); - Set_Size_Info (Index_Subtype, Index_Type); - Set_RM_Size (Index_Subtype, RM_Size (Index_Type)); - end if; - - Slice_Subtype := Create_Itype (E_Array_Subtype, N); - - Index := New_Occurrence_Of (Index_Subtype, Loc); - Set_Etype (Index, Index_Subtype); - Append (Index, Index_List); - - Set_First_Index (Slice_Subtype, Index); - Set_Etype (Slice_Subtype, Base_Type (Etype (N))); - Set_Is_Constrained (Slice_Subtype, True); - - Check_Compile_Time_Size (Slice_Subtype); - - -- The Etype of the existing Slice node is reset to this slice subtype. - -- Its bounds are obtained from its first index. - - Set_Etype (N, Slice_Subtype); - - -- In the packed case, this must be immediately frozen - - -- Couldn't we always freeze here??? and if we did, then the above - -- call to Check_Compile_Time_Size could be eliminated, which would - -- be nice, because then that routine could be made private to Freeze. - - -- Why the test for In_Spec_Expression here ??? - - if Is_Packed (Slice_Subtype) and not In_Spec_Expression then - Freeze_Itype (Slice_Subtype, N); - end if; - - end Set_Slice_Subtype; - - -------------------------------- - -- Set_String_Literal_Subtype -- - -------------------------------- - - procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id) is - Loc : constant Source_Ptr := Sloc (N); - Low_Bound : constant Node_Id := - Type_Low_Bound (Etype (First_Index (Typ))); - Subtype_Id : Entity_Id; - - begin - if Nkind (N) /= N_String_Literal then - return; - end if; - - Subtype_Id := Create_Itype (E_String_Literal_Subtype, N); - Set_String_Literal_Length (Subtype_Id, UI_From_Int - (String_Length (Strval (N)))); - Set_Etype (Subtype_Id, Base_Type (Typ)); - Set_Is_Constrained (Subtype_Id); - Set_Etype (N, Subtype_Id); - - if Is_OK_Static_Expression (Low_Bound) then - - -- The low bound is set from the low bound of the corresponding - -- index type. Note that we do not store the high bound in the - -- string literal subtype, but it can be deduced if necessary - -- from the length and the low bound. - - Set_String_Literal_Low_Bound (Subtype_Id, Low_Bound); - - else - Set_String_Literal_Low_Bound - (Subtype_Id, Make_Integer_Literal (Loc, 1)); - Set_Etype (String_Literal_Low_Bound (Subtype_Id), Standard_Positive); - - -- Build bona fide subtype for the string, and wrap it in an - -- unchecked conversion, because the backend expects the - -- String_Literal_Subtype to have a static lower bound. - - declare - Index_List : constant List_Id := New_List; - Index_Type : constant Entity_Id := Etype (First_Index (Typ)); - High_Bound : constant Node_Id := - Make_Op_Add (Loc, - Left_Opnd => New_Copy_Tree (Low_Bound), - Right_Opnd => - Make_Integer_Literal (Loc, - String_Length (Strval (N)) - 1)); - Array_Subtype : Entity_Id; - Index_Subtype : Entity_Id; - Drange : Node_Id; - Index : Node_Id; - - begin - Index_Subtype := - Create_Itype (Subtype_Kind (Ekind (Index_Type)), N); - Drange := Make_Range (Loc, New_Copy_Tree (Low_Bound), High_Bound); - Set_Scalar_Range (Index_Subtype, Drange); - Set_Parent (Drange, N); - Analyze_And_Resolve (Drange, Index_Type); - - -- In the context, the Index_Type may already have a constraint, - -- so use common base type on string subtype. The base type may - -- be used when generating attributes of the string, for example - -- in the context of a slice assignment. - - Set_Etype (Index_Subtype, Base_Type (Index_Type)); - Set_Size_Info (Index_Subtype, Index_Type); - Set_RM_Size (Index_Subtype, RM_Size (Index_Type)); - - Array_Subtype := Create_Itype (E_Array_Subtype, N); - - Index := New_Occurrence_Of (Index_Subtype, Loc); - Set_Etype (Index, Index_Subtype); - Append (Index, Index_List); - - Set_First_Index (Array_Subtype, Index); - Set_Etype (Array_Subtype, Base_Type (Typ)); - Set_Is_Constrained (Array_Subtype, True); - - Rewrite (N, - Make_Unchecked_Type_Conversion (Loc, - Subtype_Mark => New_Occurrence_Of (Array_Subtype, Loc), - Expression => Relocate_Node (N))); - Set_Etype (N, Array_Subtype); - end; - end if; - end Set_String_Literal_Subtype; - - ------------------------------ - -- Simplify_Type_Conversion -- - ------------------------------ - - procedure Simplify_Type_Conversion (N : Node_Id) is - begin - if Nkind (N) = N_Type_Conversion then - declare - Operand : constant Node_Id := Expression (N); - Target_Typ : constant Entity_Id := Etype (N); - Opnd_Typ : constant Entity_Id := Etype (Operand); - - begin - if Is_Floating_Point_Type (Opnd_Typ) - and then - (Is_Integer_Type (Target_Typ) - or else (Is_Fixed_Point_Type (Target_Typ) - and then Conversion_OK (N))) - and then Nkind (Operand) = N_Attribute_Reference - and then Attribute_Name (Operand) = Name_Truncation - - -- Special processing required if the conversion is the expression - -- of a Truncation attribute reference. In this case we replace: - - -- ityp (ftyp'Truncation (x)) - - -- by - - -- ityp (x) - - -- with the Float_Truncate flag set, which is more efficient - - then - Rewrite (Operand, - Relocate_Node (First (Expressions (Operand)))); - Set_Float_Truncate (N, True); - end if; - end; - end if; - end Simplify_Type_Conversion; - - ----------------------------- - -- Unique_Fixed_Point_Type -- - ----------------------------- - - function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id is - T1 : Entity_Id := Empty; - T2 : Entity_Id; - Item : Node_Id; - Scop : Entity_Id; - - procedure Fixed_Point_Error; - -- If true ambiguity, give details - - ----------------------- - -- Fixed_Point_Error -- - ----------------------- - - procedure Fixed_Point_Error is - begin - Error_Msg_N ("ambiguous universal_fixed_expression", N); - Error_Msg_NE ("\\possible interpretation as}", N, T1); - Error_Msg_NE ("\\possible interpretation as}", N, T2); - end Fixed_Point_Error; - - -- Start of processing for Unique_Fixed_Point_Type - - begin - -- The operations on Duration are visible, so Duration is always a - -- possible interpretation. - - T1 := Standard_Duration; - - -- Look for fixed-point types in enclosing scopes - - Scop := Current_Scope; - while Scop /= Standard_Standard loop - T2 := First_Entity (Scop); - while Present (T2) loop - if Is_Fixed_Point_Type (T2) - and then Current_Entity (T2) = T2 - and then Scope (Base_Type (T2)) = Scop - then - if Present (T1) then - Fixed_Point_Error; - return Any_Type; - else - T1 := T2; - end if; - end if; - - Next_Entity (T2); - end loop; - - Scop := Scope (Scop); - end loop; - - -- Look for visible fixed type declarations in the context - - Item := First (Context_Items (Cunit (Current_Sem_Unit))); - while Present (Item) loop - if Nkind (Item) = N_With_Clause then - Scop := Entity (Name (Item)); - T2 := First_Entity (Scop); - while Present (T2) loop - if Is_Fixed_Point_Type (T2) - and then Scope (Base_Type (T2)) = Scop - and then (Is_Potentially_Use_Visible (T2) - or else In_Use (T2)) - then - if Present (T1) then - Fixed_Point_Error; - return Any_Type; - else - T1 := T2; - end if; - end if; - - Next_Entity (T2); - end loop; - end if; - - Next (Item); - end loop; - - if Nkind (N) = N_Real_Literal then - Error_Msg_NE ("?real literal interpreted as }!", N, T1); - else - Error_Msg_NE ("?universal_fixed expression interpreted as }!", N, T1); - end if; - - return T1; - end Unique_Fixed_Point_Type; - - ---------------------- - -- Valid_Conversion -- - ---------------------- - - function Valid_Conversion - (N : Node_Id; - Target : Entity_Id; - Operand : Node_Id) return Boolean - is - Target_Type : constant Entity_Id := Base_Type (Target); - Opnd_Type : Entity_Id := Etype (Operand); - - function Conversion_Check - (Valid : Boolean; - Msg : String) return Boolean; - -- Little routine to post Msg if Valid is False, returns Valid value - - function Valid_Tagged_Conversion - (Target_Type : Entity_Id; - Opnd_Type : Entity_Id) return Boolean; - -- Specifically test for validity of tagged conversions - - function Valid_Array_Conversion return Boolean; - -- Check index and component conformance, and accessibility levels - -- if the component types are anonymous access types (Ada 2005) - - ---------------------- - -- Conversion_Check -- - ---------------------- - - function Conversion_Check - (Valid : Boolean; - Msg : String) return Boolean - is - begin - if not Valid then - Error_Msg_N (Msg, Operand); - end if; - - return Valid; - end Conversion_Check; - - ---------------------------- - -- Valid_Array_Conversion -- - ---------------------------- - - function Valid_Array_Conversion return Boolean - is - Opnd_Comp_Type : constant Entity_Id := Component_Type (Opnd_Type); - Opnd_Comp_Base : constant Entity_Id := Base_Type (Opnd_Comp_Type); - - Opnd_Index : Node_Id; - Opnd_Index_Type : Entity_Id; - - Target_Comp_Type : constant Entity_Id := - Component_Type (Target_Type); - Target_Comp_Base : constant Entity_Id := - Base_Type (Target_Comp_Type); - - Target_Index : Node_Id; - Target_Index_Type : Entity_Id; - - begin - -- Error if wrong number of dimensions - - if - Number_Dimensions (Target_Type) /= Number_Dimensions (Opnd_Type) - then - Error_Msg_N - ("incompatible number of dimensions for conversion", Operand); - return False; - - -- Number of dimensions matches - - else - -- Loop through indexes of the two arrays - - Target_Index := First_Index (Target_Type); - Opnd_Index := First_Index (Opnd_Type); - while Present (Target_Index) and then Present (Opnd_Index) loop - Target_Index_Type := Etype (Target_Index); - Opnd_Index_Type := Etype (Opnd_Index); - - -- Error if index types are incompatible - - if not (Is_Integer_Type (Target_Index_Type) - and then Is_Integer_Type (Opnd_Index_Type)) - and then (Root_Type (Target_Index_Type) - /= Root_Type (Opnd_Index_Type)) - then - Error_Msg_N - ("incompatible index types for array conversion", - Operand); - return False; - end if; - - Next_Index (Target_Index); - Next_Index (Opnd_Index); - end loop; - - -- If component types have same base type, all set - - if Target_Comp_Base = Opnd_Comp_Base then - null; - - -- Here if base types of components are not the same. The only - -- time this is allowed is if we have anonymous access types. - - -- The conversion of arrays of anonymous access types can lead - -- to dangling pointers. AI-392 formalizes the accessibility - -- checks that must be applied to such conversions to prevent - -- out-of-scope references. - - elsif - (Ekind (Target_Comp_Base) = E_Anonymous_Access_Type - or else - Ekind (Target_Comp_Base) = E_Anonymous_Access_Subprogram_Type) - and then Ekind (Opnd_Comp_Base) = Ekind (Target_Comp_Base) - and then - Subtypes_Statically_Match (Target_Comp_Type, Opnd_Comp_Type) - then - if Type_Access_Level (Target_Type) < - Type_Access_Level (Opnd_Type) - then - if In_Instance_Body then - Error_Msg_N ("?source array type " & - "has deeper accessibility level than target", Operand); - Error_Msg_N ("\?Program_Error will be raised at run time", - Operand); - Rewrite (N, - Make_Raise_Program_Error (Sloc (N), - Reason => PE_Accessibility_Check_Failed)); - Set_Etype (N, Target_Type); - return False; - - -- Conversion not allowed because of accessibility levels - - else - Error_Msg_N ("source array type " & - "has deeper accessibility level than target", Operand); - return False; - end if; - else - null; - end if; - - -- All other cases where component base types do not match - - else - Error_Msg_N - ("incompatible component types for array conversion", - Operand); - return False; - end if; - - -- Check that component subtypes statically match. For numeric - -- types this means that both must be either constrained or - -- unconstrained. For enumeration types the bounds must match. - -- All of this is checked in Subtypes_Statically_Match. - - if not Subtypes_Statically_Match - (Target_Comp_Type, Opnd_Comp_Type) - then - Error_Msg_N - ("component subtypes must statically match", Operand); - return False; - end if; - end if; - - return True; - end Valid_Array_Conversion; - - ----------------------------- - -- Valid_Tagged_Conversion -- - ----------------------------- - - function Valid_Tagged_Conversion - (Target_Type : Entity_Id; - Opnd_Type : Entity_Id) return Boolean - is - begin - -- Upward conversions are allowed (RM 4.6(22)) - - if Covers (Target_Type, Opnd_Type) - or else Is_Ancestor (Target_Type, Opnd_Type) - then - return True; - - -- Downward conversion are allowed if the operand is class-wide - -- (RM 4.6(23)). - - elsif Is_Class_Wide_Type (Opnd_Type) - and then Covers (Opnd_Type, Target_Type) - then - return True; - - elsif Covers (Opnd_Type, Target_Type) - or else Is_Ancestor (Opnd_Type, Target_Type) - then - return - Conversion_Check (False, - "downward conversion of tagged objects not allowed"); - - -- Ada 2005 (AI-251): The conversion to/from interface types is - -- always valid - - elsif Is_Interface (Target_Type) or else Is_Interface (Opnd_Type) then - return True; - - -- If the operand is a class-wide type obtained through a limited_ - -- with clause, and the context includes the non-limited view, use - -- it to determine whether the conversion is legal. - - elsif Is_Class_Wide_Type (Opnd_Type) - and then From_With_Type (Opnd_Type) - and then Present (Non_Limited_View (Etype (Opnd_Type))) - and then Is_Interface (Non_Limited_View (Etype (Opnd_Type))) - then - return True; - - elsif Is_Access_Type (Opnd_Type) - and then Is_Interface (Directly_Designated_Type (Opnd_Type)) - then - return True; - - else - Error_Msg_NE - ("invalid tagged conversion, not compatible with}", - N, First_Subtype (Opnd_Type)); - return False; - end if; - end Valid_Tagged_Conversion; - - -- Start of processing for Valid_Conversion - - begin - Check_Parameterless_Call (Operand); - - if Is_Overloaded (Operand) then - declare - I : Interp_Index; - I1 : Interp_Index; - It : Interp; - It1 : Interp; - N1 : Entity_Id; - - begin - -- Remove procedure calls, which syntactically cannot appear - -- in this context, but which cannot be removed by type checking, - -- because the context does not impose a type. - - -- When compiling for VMS, spurious ambiguities can be produced - -- when arithmetic operations have a literal operand and return - -- System.Address or a descendant of it. These ambiguities are - -- otherwise resolved by the context, but for conversions there - -- is no context type and the removal of the spurious operations - -- must be done explicitly here. - - -- The node may be labelled overloaded, but still contain only - -- one interpretation because others were discarded in previous - -- filters. If this is the case, retain the single interpretation - -- if legal. - - Get_First_Interp (Operand, I, It); - Opnd_Type := It.Typ; - Get_Next_Interp (I, It); - - if Present (It.Typ) - and then Opnd_Type /= Standard_Void_Type - then - -- More than one candidate interpretation is available - - Get_First_Interp (Operand, I, It); - while Present (It.Typ) loop - if It.Typ = Standard_Void_Type then - Remove_Interp (I); - end if; - - if Present (System_Aux_Id) - and then Is_Descendent_Of_Address (It.Typ) - then - Remove_Interp (I); - end if; - - Get_Next_Interp (I, It); - end loop; - end if; - - Get_First_Interp (Operand, I, It); - I1 := I; - It1 := It; - - if No (It.Typ) then - Error_Msg_N ("illegal operand in conversion", Operand); - return False; - end if; - - Get_Next_Interp (I, It); - - if Present (It.Typ) then - N1 := It1.Nam; - It1 := Disambiguate (Operand, I1, I, Any_Type); - - if It1 = No_Interp then - Error_Msg_N ("ambiguous operand in conversion", Operand); - - Error_Msg_Sloc := Sloc (It.Nam); - Error_Msg_N ("\\possible interpretation#!", Operand); - - Error_Msg_Sloc := Sloc (N1); - Error_Msg_N ("\\possible interpretation#!", Operand); - - return False; - end if; - end if; - - Set_Etype (Operand, It1.Typ); - Opnd_Type := It1.Typ; - end; - end if; - - -- Numeric types - - if Is_Numeric_Type (Target_Type) then - - -- A universal fixed expression can be converted to any numeric type - - if Opnd_Type = Universal_Fixed then - return True; - - -- Also no need to check when in an instance or inlined body, because - -- the legality has been established when the template was analyzed. - -- Furthermore, numeric conversions may occur where only a private - -- view of the operand type is visible at the instantiation point. - -- This results in a spurious error if we check that the operand type - -- is a numeric type. - - -- Note: in a previous version of this unit, the following tests were - -- applied only for generated code (Comes_From_Source set to False), - -- but in fact the test is required for source code as well, since - -- this situation can arise in source code. - - elsif In_Instance or else In_Inlined_Body then - return True; - - -- Otherwise we need the conversion check - - else - return Conversion_Check - (Is_Numeric_Type (Opnd_Type), - "illegal operand for numeric conversion"); - end if; - - -- Array types - - elsif Is_Array_Type (Target_Type) then - if not Is_Array_Type (Opnd_Type) - or else Opnd_Type = Any_Composite - or else Opnd_Type = Any_String - then - Error_Msg_N - ("illegal operand for array conversion", Operand); - return False; - else - return Valid_Array_Conversion; - end if; - - -- Ada 2005 (AI-251): Anonymous access types where target references an - -- interface type. - - elsif (Ekind (Target_Type) = E_General_Access_Type - or else - Ekind (Target_Type) = E_Anonymous_Access_Type) - and then Is_Interface (Directly_Designated_Type (Target_Type)) - then - -- Check the static accessibility rule of 4.6(17). Note that the - -- check is not enforced when within an instance body, since the RM - -- requires such cases to be caught at run time. - - if Ekind (Target_Type) /= E_Anonymous_Access_Type then - if Type_Access_Level (Opnd_Type) > - Type_Access_Level (Target_Type) - then - -- In an instance, this is a run-time check, but one we know - -- will fail, so generate an appropriate warning. The raise - -- will be generated by Expand_N_Type_Conversion. - - if In_Instance_Body then - Error_Msg_N - ("?cannot convert local pointer to non-local access type", - Operand); - Error_Msg_N - ("\?Program_Error will be raised at run time", Operand); - else - Error_Msg_N - ("cannot convert local pointer to non-local access type", - Operand); - return False; - end if; - - -- Special accessibility checks are needed in the case of access - -- discriminants declared for a limited type. - - elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type - and then not Is_Local_Anonymous_Access (Opnd_Type) - then - -- When the operand is a selected access discriminant the check - -- needs to be made against the level of the object denoted by - -- the prefix of the selected name. (Object_Access_Level - -- handles checking the prefix of the operand for this case.) - - if Nkind (Operand) = N_Selected_Component - and then Object_Access_Level (Operand) > - Type_Access_Level (Target_Type) - then - -- In an instance, this is a run-time check, but one we - -- know will fail, so generate an appropriate warning. - -- The raise will be generated by Expand_N_Type_Conversion. - - if In_Instance_Body then - Error_Msg_N - ("?cannot convert access discriminant to non-local" & - " access type", Operand); - Error_Msg_N - ("\?Program_Error will be raised at run time", Operand); - else - Error_Msg_N - ("cannot convert access discriminant to non-local" & - " access type", Operand); - return False; - end if; - end if; - - -- The case of a reference to an access discriminant from - -- within a limited type declaration (which will appear as - -- a discriminal) is always illegal because the level of the - -- discriminant is considered to be deeper than any (nameable) - -- access type. - - if Is_Entity_Name (Operand) - and then not Is_Local_Anonymous_Access (Opnd_Type) - and then (Ekind (Entity (Operand)) = E_In_Parameter - or else Ekind (Entity (Operand)) = E_Constant) - and then Present (Discriminal_Link (Entity (Operand))) - then - Error_Msg_N - ("discriminant has deeper accessibility level than target", - Operand); - return False; - end if; - end if; - end if; - - return True; - - -- General and anonymous access types - - elsif (Ekind (Target_Type) = E_General_Access_Type - or else Ekind (Target_Type) = E_Anonymous_Access_Type) - and then - Conversion_Check - (Is_Access_Type (Opnd_Type) - and then Ekind (Opnd_Type) /= - E_Access_Subprogram_Type - and then Ekind (Opnd_Type) /= - E_Access_Protected_Subprogram_Type, - "must be an access-to-object type") - then - if Is_Access_Constant (Opnd_Type) - and then not Is_Access_Constant (Target_Type) - then - Error_Msg_N - ("access-to-constant operand type not allowed", Operand); - return False; - end if; - - -- Check the static accessibility rule of 4.6(17). Note that the - -- check is not enforced when within an instance body, since the RM - -- requires such cases to be caught at run time. - - if Ekind (Target_Type) /= E_Anonymous_Access_Type - or else Is_Local_Anonymous_Access (Target_Type) - then - if Type_Access_Level (Opnd_Type) - > Type_Access_Level (Target_Type) - then - -- In an instance, this is a run-time check, but one we - -- know will fail, so generate an appropriate warning. - -- The raise will be generated by Expand_N_Type_Conversion. - - if In_Instance_Body then - Error_Msg_N - ("?cannot convert local pointer to non-local access type", - Operand); - Error_Msg_N - ("\?Program_Error will be raised at run time", Operand); - - else - -- Avoid generation of spurious error message - - if not Error_Posted (N) then - Error_Msg_N - ("cannot convert local pointer to non-local access type", - Operand); - end if; - - return False; - end if; - - -- Special accessibility checks are needed in the case of access - -- discriminants declared for a limited type. - - elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type - and then not Is_Local_Anonymous_Access (Opnd_Type) - then - - -- When the operand is a selected access discriminant the check - -- needs to be made against the level of the object denoted by - -- the prefix of the selected name. (Object_Access_Level - -- handles checking the prefix of the operand for this case.) - - if Nkind (Operand) = N_Selected_Component - and then Object_Access_Level (Operand) > - Type_Access_Level (Target_Type) - then - -- In an instance, this is a run-time check, but one we - -- know will fail, so generate an appropriate warning. - -- The raise will be generated by Expand_N_Type_Conversion. - - if In_Instance_Body then - Error_Msg_N - ("?cannot convert access discriminant to non-local" & - " access type", Operand); - Error_Msg_N - ("\?Program_Error will be raised at run time", - Operand); - - else - Error_Msg_N - ("cannot convert access discriminant to non-local" & - " access type", Operand); - return False; - end if; - end if; - - -- The case of a reference to an access discriminant from - -- within a limited type declaration (which will appear as - -- a discriminal) is always illegal because the level of the - -- discriminant is considered to be deeper than any (nameable) - -- access type. - - if Is_Entity_Name (Operand) - and then (Ekind (Entity (Operand)) = E_In_Parameter - or else Ekind (Entity (Operand)) = E_Constant) - and then Present (Discriminal_Link (Entity (Operand))) - then - Error_Msg_N - ("discriminant has deeper accessibility level than target", - Operand); - return False; - end if; - end if; - end if; - - declare - function Full_Designated_Type (T : Entity_Id) return Entity_Id; - -- Helper function to handle limited views - - -------------------------- - -- Full_Designated_Type -- - -------------------------- - - function Full_Designated_Type (T : Entity_Id) return Entity_Id is - Desig : constant Entity_Id := Designated_Type (T); - begin - if From_With_Type (Desig) - and then Is_Incomplete_Type (Desig) - and then Present (Non_Limited_View (Desig)) - then - return Non_Limited_View (Desig); - else - return Desig; - end if; - end Full_Designated_Type; - - Target : constant Entity_Id := Full_Designated_Type (Target_Type); - Opnd : constant Entity_Id := Full_Designated_Type (Opnd_Type); - - Same_Base : constant Boolean := - Base_Type (Target) = Base_Type (Opnd); - - begin - if Is_Tagged_Type (Target) then - return Valid_Tagged_Conversion (Target, Opnd); - - else - if not Same_Base then - Error_Msg_NE - ("target designated type not compatible with }", - N, Base_Type (Opnd)); - return False; - - -- Ada 2005 AI-384: legality rule is symmetric in both - -- designated types. The conversion is legal (with possible - -- constraint check) if either designated type is - -- unconstrained. - - elsif Subtypes_Statically_Match (Target, Opnd) - or else - (Has_Discriminants (Target) - and then - (not Is_Constrained (Opnd) - or else not Is_Constrained (Target))) - then - -- Special case, if Value_Size has been used to make the - -- sizes different, the conversion is not allowed even - -- though the subtypes statically match. - - if Known_Static_RM_Size (Target) - and then Known_Static_RM_Size (Opnd) - and then RM_Size (Target) /= RM_Size (Opnd) - then - Error_Msg_NE - ("target designated subtype not compatible with }", - N, Opnd); - Error_Msg_NE - ("\because sizes of the two designated subtypes differ", - N, Opnd); - return False; - - -- Normal case where conversion is allowed - - else - return True; - end if; - - else - Error_Msg_NE - ("target designated subtype not compatible with }", - N, Opnd); - return False; - end if; - end if; - end; - - -- Access to subprogram types. If the operand is an access parameter, - -- the type has a deeper accessibility that any master, and cannot - -- be assigned. We must make an exception if the conversion is part - -- of an assignment and the target is the return object of an extended - -- return statement, because in that case the accessibility check - -- takes place after the return. - - elsif Is_Access_Subprogram_Type (Target_Type) - and then No (Corresponding_Remote_Type (Opnd_Type)) - then - if Ekind (Base_Type (Opnd_Type)) = E_Anonymous_Access_Subprogram_Type - and then Is_Entity_Name (Operand) - and then Ekind (Entity (Operand)) = E_In_Parameter - and then - (Nkind (Parent (N)) /= N_Assignment_Statement - or else not Is_Entity_Name (Name (Parent (N))) - or else not Is_Return_Object (Entity (Name (Parent (N))))) - then - Error_Msg_N - ("illegal attempt to store anonymous access to subprogram", - Operand); - Error_Msg_N - ("\value has deeper accessibility than any master " & - "(RM 3.10.2 (13))", - Operand); - - Error_Msg_NE - ("\use named access type for& instead of access parameter", - Operand, Entity (Operand)); - end if; - - -- Check that the designated types are subtype conformant - - Check_Subtype_Conformant (New_Id => Designated_Type (Target_Type), - Old_Id => Designated_Type (Opnd_Type), - Err_Loc => N); - - -- Check the static accessibility rule of 4.6(20) - - if Type_Access_Level (Opnd_Type) > - Type_Access_Level (Target_Type) - then - Error_Msg_N - ("operand type has deeper accessibility level than target", - Operand); - - -- Check that if the operand type is declared in a generic body, - -- then the target type must be declared within that same body - -- (enforces last sentence of 4.6(20)). - - elsif Present (Enclosing_Generic_Body (Opnd_Type)) then - declare - O_Gen : constant Node_Id := - Enclosing_Generic_Body (Opnd_Type); - - T_Gen : Node_Id; - - begin - T_Gen := Enclosing_Generic_Body (Target_Type); - while Present (T_Gen) and then T_Gen /= O_Gen loop - T_Gen := Enclosing_Generic_Body (T_Gen); - end loop; - - if T_Gen /= O_Gen then - Error_Msg_N - ("target type must be declared in same generic body" - & " as operand type", N); - end if; - end; - end if; - - return True; - - -- Remote subprogram access types - - elsif Is_Remote_Access_To_Subprogram_Type (Target_Type) - and then Is_Remote_Access_To_Subprogram_Type (Opnd_Type) - then - -- It is valid to convert from one RAS type to another provided - -- that their specification statically match. - - Check_Subtype_Conformant - (New_Id => - Designated_Type (Corresponding_Remote_Type (Target_Type)), - Old_Id => - Designated_Type (Corresponding_Remote_Type (Opnd_Type)), - Err_Loc => - N); - return True; - - -- If both are tagged types, check legality of view conversions - - elsif Is_Tagged_Type (Target_Type) - and then Is_Tagged_Type (Opnd_Type) - then - return Valid_Tagged_Conversion (Target_Type, Opnd_Type); - - -- Types derived from the same root type are convertible - - elsif Root_Type (Target_Type) = Root_Type (Opnd_Type) then - return True; - - -- In an instance or an inlined body, there may be inconsistent - -- views of the same type, or of types derived from a common root. - - elsif (In_Instance or In_Inlined_Body) - and then - Root_Type (Underlying_Type (Target_Type)) = - Root_Type (Underlying_Type (Opnd_Type)) - then - return True; - - -- Special check for common access type error case - - elsif Ekind (Target_Type) = E_Access_Type - and then Is_Access_Type (Opnd_Type) - then - Error_Msg_N ("target type must be general access type!", N); - Error_Msg_NE ("add ALL to }!", N, Target_Type); - - return False; - - else - Error_Msg_NE ("invalid conversion, not compatible with }", - N, Opnd_Type); - - return False; - end if; - end Valid_Conversion; - -end Sem_Res; |