X-Git-Url: https://oss.titaniummirror.com/gitweb?a=blobdiff_plain;f=gcc%2Fada%2Fsem_res.adb;fp=gcc%2Fada%2Fsem_res.adb;h=0000000000000000000000000000000000000000;hb=6fed43773c9b0ce596dca5686f37ac3fc0fa11c0;hp=9b73ee21aee2bc09d1eb272c3969fcffb9ce2526;hpb=27b11d56b743098deb193d510b337ba22dc52e5c;p=msp430-gcc.git diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb deleted file mode 100644 index 9b73ee21..00000000 --- a/gcc/ada/sem_res.adb +++ /dev/null @@ -1,6444 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S E M _ R E S -- --- -- --- B o d y -- --- -- --- $Revision: 1.6.10.1 $ --- -- --- Copyright (C) 1992-2001, 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 2, 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 COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Atree; use Atree; -with Checks; use Checks; -with Debug; use Debug; -with Debug_A; use Debug_A; -with Einfo; use Einfo; -with Errout; use Errout; -with Expander; use Expander; -with Exp_Ch7; use Exp_Ch7; -with Exp_Util; use Exp_Util; -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 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_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 Stand; use Stand; -with Stringt; use Stringt; -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 Ambiguous_Character (C : Node_Id); - -- Give list of candidate interpretations when a character literal cannot - -- be resolved. - - 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. - - 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_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_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. - - 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 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); - -- An operator can rename another, e.g. in an instantiation. In that - -- case, the proper operator node must be constructed. - - 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 String the function is a no-op. - - procedure Set_Slice_Subtype (N : Node_Id); - -- Build subtype of array type, with the range specified by the slice. - - 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); - Error_Msg_N - ("\possible interpretations: Character, Wide_Character!", C); - - E := Current_Entity (C); - - if Present (E) then - - while Present (E) loop - Error_Msg_NE ("\possible interpretation:}!", C, Etype (E)); - E := Homonym (E); - end loop; - end if; - end if; - end Ambiguous_Character; - - ------------------------- - -- Analyze_And_Resolve -- - ------------------------- - - procedure Analyze_And_Resolve (N : Node_Id) is - begin - Analyze (N); - Resolve (N, Etype (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 : Entity_Id := Current_Scope; - - begin - if Suppress = All_Checks then - declare - Svg : constant Suppress_Record := Scope_Suppress; - - begin - Scope_Suppress := (others => True); - Analyze_And_Resolve (N, Typ); - Scope_Suppress := Svg; - end; - - else - declare - Svg : constant Boolean := Get_Scope_Suppress (Suppress); - - begin - Set_Scope_Suppress (Suppress, True); - Analyze_And_Resolve (N, Typ); - Set_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 : Entity_Id := Current_Scope; - - begin - if Suppress = All_Checks then - declare - Svg : constant Suppress_Record := Scope_Suppress; - - begin - Scope_Suppress := (others => True); - Analyze_And_Resolve (N); - Scope_Suppress := Svg; - end; - - else - declare - Svg : constant Boolean := Get_Scope_Suppress (Suppress); - - begin - Set_Scope_Suppress (Suppress, True); - Analyze_And_Resolve (N); - Set_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 default expression is legal. - - if In_Default_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_Declaration - then - Error_Msg_N ("discriminant cannot constrain scalar type", N); - - elsif Nkind (P) = N_Index_Or_Discriminant_Constraint then - - -- The following check catches the unusual case where - -- a discriminant appears within an index constraint - -- that is part of a larger expression within a constraint - -- on a component, e.g. "C : Int range 1 .. F (new A(1 .. D))". - -- For now we only check case of record components, and - -- note that a similar check should also apply in the - -- case of discriminant constraints below. ??? - - -- Note that the check for N_Subtype_Declaration below is to - -- detect the valid use of discriminants in the constraints of a - -- subtype declaration when this subtype declaration appears - -- inside the scope of a record type (which is syntactically - -- illegal, but which may be created as part of derived type - -- processing for records). See Sem_Ch3.Build_Derived_Record_Type - -- for more info. - - if Ekind (Current_Scope) = E_Record_Type - and then Scope (Disc) = Current_Scope - and then not - (Nkind (Parent (P)) = N_Subtype_Indication - and then - (Nkind (Parent (Parent (P))) = N_Component_Declaration - or else Nkind (Parent (Parent (P))) = 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 beginner 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. - - 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. - - function Large_Storage_Type (T : Entity_Id) return Boolean is - begin - return - T = Standard_Integer - or else - T = Standard_Positive - or else - T = Standard_Natural; - end Large_Storage_Type; - - 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 not Present (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 of this type may raise Storage_Error?", - N); - - <> - null; - - end; - end if; - - -- Legal case is in index or discriminant constraint - - elsif Nkind (PN) = N_Index_Or_Discriminant_Constraint - or else Nkind (PN) = N_Discriminant_Association - then - if Paren_Count (N) > 0 then - Error_Msg_N - ("discriminant in constraint must appear alone", N); - end if; - - return; - - -- Otherwise, context is an expression. It should not be within - -- (i.e. a subexpression of) a constraint for a component. - - else - D := PN; - P := Parent (PN); - - while Nkind (P) /= N_Component_Declaration - and then Nkind (P) /= N_Subtype_Indication - and then Nkind (P) /= N_Entry_Declaration - loop - D := P; - P := Parent (P); - exit when No (P); - end loop; - - -- If the discriminant is used in an expression that is a bound - -- of a scalar type, an Itype is created and the bounds are attached - -- to its range, not to the original subtype indication. Such use - -- is of course a double fault. - - if (Nkind (P) = N_Subtype_Indication - and then - (Nkind (Parent (P)) = N_Component_Declaration - or else Nkind (Parent (P)) = 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 - Orig_Node : Node_Id := Original_Node (N); - - begin - if Comes_From_Source (Orig_Node) - and then not In_Open_Scopes (Scope (T)) - and then not Is_Potentially_Use_Visible (T) - and then not In_Use (T) - and then not In_Use (Scope (T)) - and then (not Present (Entity (N)) - or else Ekind (Entity (N)) /= E_Function) - and then (Nkind (Orig_Node) /= N_Function_Call - or else Nkind (Name (Orig_Node)) /= N_Expanded_Name - or else Entity (Prefix (Name (Orig_Node))) /= Scope (T)) - and then not In_Instance - 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_Infinite_Recursion -- - ------------------------------ - - function Check_Infinite_Recursion (N : Node_Id) return Boolean is - P : Node_Id; - C : Node_Id; - - begin - -- Loop moving up tree, quitting if something tells us we are - -- definitely not in an infinite recursion situation. - - C := N; - loop - P := Parent (C); - exit when Nkind (P) = N_Subprogram_Body; - - if Nkind (P) = N_Or_Else or else - Nkind (P) = N_And_Then or else - Nkind (P) = N_If_Statement or else - Nkind (P) = N_Case_Statement - then - return False; - - elsif Nkind (P) = N_Handled_Sequence_Of_Statements - and then C /= First (Statements (P)) - then - return False; - - else - C := P; - end if; - end loop; - - Warn_On_Instance := True; - Error_Msg_N ("possible infinite recursion?", N); - Error_Msg_N ("\Storage_Error may be raised at run time?", N); - Warn_On_Instance := False; - - return True; - end Check_Infinite_Recursion; - - ------------------------------- - -- Check_Initialization_Call -- - ------------------------------- - - procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id) is - Typ : Entity_Id := Etype (First_Formal (Nam)); - - function Uses_SS (T : Entity_Id) return Boolean; - - function Uses_SS (T : Entity_Id) return Boolean is - Comp : Entity_Id; - Expr : Node_Id; - - begin - if Is_Controlled (T) - or else Has_Controlled_Component (T) - or else Functions_Return_By_DSP_On_Target - then - return False; - - elsif Is_Array_Type (T) then - return Uses_SS (Component_Type (T)); - - elsif Is_Record_Type (T) then - Comp := First_Component (T); - - while Present (Comp) loop - - if Ekind (Comp) = E_Component - and then Nkind (Parent (Comp)) = N_Component_Declaration - then - Expr := Expression (Parent (Comp)); - - if Nkind (Expr) = N_Function_Call - 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; - - begin - 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; - - begin - if Nkind (N) in N_Has_Etype and then Etype (N) = Any_Type 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 suprogram type is not that of a - -- procedure or entry. - - or else - (Nkind (N) = N_Explicit_Dereference - and then Ekind (Etype (N)) = E_Subprogram_Type - and then Base_Type (Etype (Etype (N))) /= Standard_Void_Type) - - -- 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_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; - 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 Is_Definite_Access_Type (E : Entity_Id) return Boolean; - -- Determine whether E is an access type declared by an access decla- - -- ration, and not an (anonymous) allocator type. - - 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. - - ----------------------------- - -- 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; - - --------------------------- - -- 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; - - --------------------------- - -- Operand_Type_In_Scope -- - --------------------------- - - -- 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; - - 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; - - 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 - Error := True; - - 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); - Set_Etype (Op_Node, Base_Type (Etype (N))); - Set_Entity (Op_Node, Op_Id); - Generate_Reference (Op_Id, N, ' '); - Rewrite (N, Op_Node); - Resolve (N, Typ); - - -- 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; - - ----------------------------- - -- Pre_Analyze_And_Resolve -- - ----------------------------- - - procedure Pre_Analyze_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 Pre_Analyze_And_Resolve; - - -- Version without context type. - - procedure Pre_Analyze_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 Pre_Analyze_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 - I : Interp_Index; - I1 : Interp_Index := 0; -- prevent junk warning - It : Interp; - It1 : Interp; - Found : Boolean := False; - Seen : Entity_Id := Empty; -- prevent junk warning - Ctx_Type : Entity_Id := Typ; - Expr_Type : Entity_Id := Empty; -- prevent junk warning - Ambiguous : Boolean := False; - - 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 - - -------------------- - -- 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 => Char_Code (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; - - -- 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 fat pointer with a reference to a RAS as - -- original access type. - - if - (Ekind (Typ) = E_Access_Subprogram_Type - and then Present (Equivalent_Type (Typ))) - or else - (Ekind (Typ) = E_Record_Type - and then Present (Corresponding_Remote_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 Attr = Attribute_Access - or else Attr = Attribute_Unchecked_Access - or else Attr = Attribute_Unrestricted_Access - 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 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; - - -- 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 - Get_First_Interp (N, I, It); - - -- Loop through possible interpretations - - 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 Covers (Typ, It.Typ) then - - -- First matching interpretation - - if not Found then - Found := True; - I1 := I; - Seen := It.Nam; - Expr_Type := It.Typ; - - -- Matching intepretation 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 - Error_Msg_Sloc := Sloc (Seen); - It1 := Disambiguate (N, I1, I, Typ); - - if It1 = No_Interp then - - -- Before we issue an ambiguity complaint, check for - -- the case of a subprogram call where at least one - -- of the arguments is Any_Type, and if so, suppress - -- the message, since it is a cascaded error. - - if Nkind (N) = N_Function_Call - or else Nkind (N) = N_Procedure_Call_Statement - then - declare - A : Node_Id := First_Actual (N); - E : Node_Id; - - begin - 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 - Error_Msg_NE - ("ambiguous expression (cannot resolve&)!", - N, It.Nam); - Error_Msg_N - ("possible interpretation#!", N); - Ambiguous := True; - end if; - - Error_Msg_Sloc := Sloc (It.Nam); - Error_Msg_N ("possible interpretation#!", N); - - -- Disambiguation has succeeded. Skip the remaining - -- interpretations. - else - Seen := It1.Nam; - Expr_Type := It1.Typ; - - while Present (It.Typ) loop - Get_Next_Interp (I, It); - end loop; - 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 a call with a name that is an explicit dereference, - -- there is nothing to be done at this point. - - elsif Nkind (N) = N_Explicit_Dereference - or else Nkind (N) = N_Attribute_Reference - or else Nkind (N) = N_And_Then - or else Nkind (N) = N_Indexed_Component - or else Nkind (N) = N_Or_Else - or else Nkind (N) = N_Range - or else Nkind (N) = N_Selected_Component - or else Nkind (N) = N_Slice - or else Nkind (Name (N)) = N_Explicit_Dereference - then - null; - - -- For procedure or function calls, set the type of the - -- name, and also the entity pointer for the prefix - - elsif (Nkind (N) = N_Procedure_Call_Statement - or else Nkind (N) = 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; - - -- Here if interpetation is incompatible with context type - - else - if Debug_Flag_V then - Write_Str (" intepretation incompatible with context"); - Write_Eol; - end if; - end if; - - -- Move to next interpretation - - exit Interp_Loop when not Present (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 - Error_Msg_N ("expect procedure name in procedure call", N); - 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. - - 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 - Check_Elmt (Expression (Elmt)); - Next (Elmt); - end loop; - end if; - end Check_Aggr; - - 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, Etype (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 - Error_Msg_Node_2 := Typ; - Error_Msg_NE ("no visible interpretation of&" & - " matches expected type&", N, Name (N)); - - 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.Typ; - Error_Msg_NE ("\& declared#, type&", - N, It.Nam); - - 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 - -- A user-defined operator is tranformed 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))) then - Rewrite_Renamed_Operator (N, Alias (Entity (N))); - end if; - end if; - - -- 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; - - 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_In | N_Not_In - => Resolve_Membership_Op (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_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(9,10)). - - -- 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; - - -- 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_Record := Scope_Suppress; - - begin - Scope_Suppress := (others => True); - Resolve (N, Typ); - Scope_Suppress := Svg; - end; - - else - declare - Svg : constant Boolean := Get_Scope_Suppress (Suppress); - - begin - Set_Scope_Suppress (Suppress, True); - Resolve (N, Typ); - Set_Scope_Suppress (Suppress, Svg); - end; - end if; - 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; - - 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. - - -------------------- - -- Insert_Default -- - -------------------- - - procedure Insert_Default is - Actval : Node_Id; - Assoc : Node_Id; - - begin - -- 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. - - if Present (Default_Value (F)) then - - 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); - Analyze_And_Resolve (Actval, Etype (Actval)); - else - Set_Parent (Actval, N); - - -- Resolve aggregates with their base type, to avoid scope - -- anomalies: the subtype was first built in the suprogram - -- 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; - 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; - - else - -- Missing argument in call, nothing to insert. - return; - 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)); - 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 not Present (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; - - -- Start of processing for Resolve_Actuals - - begin - A := First_Actual (N); - F := First_Formal (Nam); - - while Present (F) loop - - if Present (A) - and then (Nkind (Parent (A)) /= N_Parameter_Association - or else - Chars (Selector_Name (Parent (A))) = Chars (F)) - then - -- 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 - -- a tagged type conversion with a class-wide actual. In that - -- case we want the tag check to occur and no temporary will - -- will be needed (no representation change can occur) and - -- the parameter is passed by reference, so we go ahead and - -- resolve the type conversion. - - 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 Conversion_OK (A) - or else Valid_Conversion (A, Etype (A), Expression (A)) - then - Resolve (Expression (A), Etype (Expression (A))); - end if; - - else - Resolve (A, Etype (F)); - end if; - - A_Typ := Etype (A); - F_Typ := Etype (F); - - if Ekind (F) /= E_In_Parameter - and then not Is_OK_Variable_For_Out_Formal (A) - then - -- Specialize error message for protected procedure call - -- within function call of the same protected object. - - if Is_Entity_Name (A) - and then Chars (Entity (A)) = Name_uObject - and then Ekind (Current_Scope) = E_Function - and then Convention (Current_Scope) = Convention_Protected - and then Ekind (Nam) /= E_Function - then - Error_Msg_N ("within protected function, protected " & - "object is constant", A); - Error_Msg_N ("\cannot call operation that may modify it", A); - else - Error_Msg_NE ("actual for& must be a variable", A, F); - end if; - end if; - - if Ekind (F) /= E_Out_Parameter then - Check_Unset_Reference (A); - - if 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; - - -- 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; - 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)) - - if Is_Controlling_Formal (F) then - Set_Is_Controlling_Actual (A); - 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) then - Error_Msg_Node_2 := F_Typ; - Error_Msg_NE - ("& is not a primitive 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 (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) then - Error_Msg_Node_2 := Designated_Type (F_Typ); - Error_Msg_NE - ("& is not a primitive 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; - Next_Actual (A); - - 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; - Disc_Exp : Node_Id; - - 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 (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)) - 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)); - - -- 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 contrain an access discriminant cannot be - -- deeper than the type of the allocator (in constrast 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. Note that specialized checks are - -- needed for the cases of a constraint expression which is an - -- access attribute or an access discriminant. - - if Nkind (Original_Node (E)) = N_Subtype_Indication - and then Ekind (Typ) /= E_Anonymous_Access_Type - 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; - - if Type_Access_Level (Etype (Disc_Exp)) - > Type_Access_Level (Typ) - then - Error_Msg_N - ("operand type has deeper level than allocator type", - Disc_Exp); - - 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 (Typ) - then - Error_Msg_N - ("prefix of attribute has deeper level than" - & " allocator type", Disc_Exp); - - -- When the operand 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 (Typ) - then - Error_Msg_N - ("access discriminant has deeper level than" - & " allocator type", Disc_Exp); - end if; - end if; - Next_Discriminant (Discrim); - Next (Constr); - end loop; - end if; - end if; - 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)); - end; - 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); - T : Entity_Id; - TL : Entity_Id := Base_Type (Etype (L)); - TR : Entity_Id := Base_Type (Etype (R)); - - 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 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 - - function Universal_Interpretation (N : Node_Id) return Entity_Id; - -- Find universal type of operand, if any. - - ----------------------------- - -- 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 N = L then - Set_Analyzed (R, False); - Resolve (R, B_Typ); - else - Set_Analyzed (L, False); - Resolve (L, B_Typ); - end if; - - else - Resolve (N, Etype (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; - - ------------------------------ - -- Universal_Interpretation -- - ------------------------------ - - function Universal_Interpretation (N : Node_Id) return Entity_Id is - Index : Interp_Index; - It : Interp; - - begin - if not Is_Overloaded (N) then - - if Etype (N) = Universal_Integer - or else Etype (N) = Universal_Real - then - return Etype (N); - else - return Empty; - end if; - - else - Get_First_Interp (N, Index, It); - - while Present (It.Typ) loop - - if It.Typ = Universal_Integer - or else It.Typ = Universal_Real - then - return It.Typ; - end if; - - Get_Next_Interp (Index, It); - end loop; - - return Empty; - end if; - end Universal_Interpretation; - - -- 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 Present (First_Rep_Item (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 (N) = N_Op_Multiply or else - Nkind (N) = 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; - - if Etype (N) = Universal_Fixed - or else Etype (N) = Any_Fixed - then - if B_Typ = Universal_Fixed - and then Nkind (Parent (N)) /= N_Type_Conversion - and then Nkind (Parent (N)) /= 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_83 - and then Etype (N) = Universal_Fixed - and then Nkind (Parent (N)) /= N_Type_Conversion - and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion - then - Error_Msg_N - ("(Ada 83) fixed-point operation " & - "needs explicit conversion", - N); - end if; - - Set_Etype (N, B_Typ); - 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); - 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 - Set_Do_Overflow_Check (N); - end if; - - if (Nkind (N) = N_Op_Divide - or else Nkind (N) = N_Op_Rem - or else Nkind (N) = N_Op_Mod) - and then not Division_Checks_Suppressed (Etype (N)) - then - Set_Do_Division_Check (N); - 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; - - 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. - - Get_First_Interp (Subp, I, It); - Nam := Empty; - - 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; - - -- 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 (Subp) = N_Selected_Component - or else Nkind (Subp) = 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); - 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); - Generate_Reference (Nam, Subp); - - -- 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); - Generate_Reference (Nam, Subp); - exit; - end if; - - Get_Next_Interp (I, It); - end loop; - 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); - exit when No (P); - - if Nkind (P) = N_Entry_Body then - Error_Msg_NE - ("& should not be used in entry body ('R'M C.7(17))", - N, Nam); - exit; - 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 - Error_Msg_N ("entry call required in select statement", N); - end if; - - -- Freeze the subprogram name if not in default 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_Default_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. - - elsif Needs_No_Actuals (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; - - begin - - if Component_Type (Etype (Nam)) /= Any_Type then - Index_Node := - Make_Indexed_Component (Loc, - Prefix => - Make_Function_Call (Loc, - Name => New_Occurrence_Of (Nam, Loc)), - 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); - Check_Elab_Call (Prefix (N)); - 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. - - Scop := Current_Scope; - - if Nam = Scop - and then not Restrictions (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. - - null; - - -- If call is to immediately containing subprogram, then check for - -- the case of a possible run-time detectable infinite recursion. - - else - while Scop /= Standard_Standard loop - if Nam = Scop then - -- Although in general 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 procedure, 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 we 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 - 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; - end if; - - Scop := Scope (Scop); - end loop; - 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 3 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 other case is intrinsic subprograms (Unchecked_Conversion and - -- source information functions) that do not use the secondary stack - -- even though the return type is unconstrained. - - -- 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 Expander_Active - and then Is_Type (Etype (Nam)) - and then Requires_Transient_Scope (Etype (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 => not Functions_Return_By_DSP_On_Target); - - elsif Chars (Nam) = Name_uInit_Proc - 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. - - return; - 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); - - -- If the subprogram is abstract, check that the call has a - -- controlling argument (i.e. is dispatching) or is disptaching on - -- result - - if Is_Abstract (Nam) - and then No (Controlling_Argument (N)) - and then not Is_Class_Wide_Type (Typ) - and then not Is_Tag_Indeterminate (N) - then - Error_Msg_N ("call to abstract subprogram must be dispatching", N); - end if; - - elsif Is_Abstract (Nam) - and then not In_Instance - then - Error_Msg_NE ("cannot call abstract subprogram &!", N, Nam); - end if; - - if Is_Intrinsic_Subprogram (Nam) then - Check_Intrinsic_Call (N); - end if; - - -- If we fall through we definitely have a non-static call - - 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_Character literals must always be defined, since the set of - -- wide character literals is complete, i.e. if a character literal - -- is accepted by the parser, then it is OK for wide character. - - if Root_Type (B_Typ) = Standard_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 (Char_Literal_Value (N)) then - return; - end if; - - -- 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. - - 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, 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 - if Comes_From_Source (N) - and then Has_Unchecked_Union (T) - then - Error_Msg_N - ("cannot compare Unchecked_Union values", N); - end if; - - Resolve (L, T); - Resolve (R, T); - Check_Unset_Reference (L); - Check_Unset_Reference (R); - Generate_Operator_Reference (N); - 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 : Node_Id := Low_Bound (R); - H : 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 - -- 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_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_Default_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 : Entity_Id := Entry_Index_Type (E); - Tsk : Entity_Id := Scope (E); - Lo : Node_Id := Type_Low_Bound (Typ); - Hi : 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 : 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 : Node_Id := Prefix (Entry_Name); - I : Interp_Index; - It : Interp; - Ent : Entity_Id := Entity (Selector_Name (Entry_Name)); - - 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), Etype (Prefix (Entry_Name))); - - else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component); - Nam := Entity (Selector_Name (Prefix (Entry_Name))); - Resolve (Prefix (Prefix (Entry_Name)), - Etype (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 - -- 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; - - -- 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. - - if Was_Over then - Normalize_Actuals (N, Nam, False, Norm_OK); - pragma Assert (Norm_OK); - 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 => not Functions_Return_By_DSP_On_Target); - 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 := Current_Scope; - - 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; - - 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 - 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; - - if Comes_From_Source (N) - and then Has_Unchecked_Union (T) - then - Error_Msg_N - ("cannot compare Unchecked_Union values", N); - end if; - - Resolve (L, T); - Resolve (R, T); - Check_Unset_Reference (L); - Check_Unset_Reference (R); - Generate_Operator_Reference (N); - - -- 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 (Entity (N)) - then - Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N)); - end if; - end if; - end Resolve_Equality_Op; - - ---------------------------------- - -- Resolve_Explicit_Dereference -- - ---------------------------------- - - procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id) is - P : constant Node_Id := Prefix (N); - I : Interp_Index; - It : Interp; - - begin - -- Now that we know the type, check that this is not a - -- dereference of an uncompleted type. Note that this - -- is not entirely correct, because dereferences of - -- private types are legal in default expressions. - -- This consideration also applies to similar checks - -- for allocators, qualified expressions, and type - -- conversions. ??? - - Check_Fully_Declared (Typ, N); - - 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; - - Resolve (P, It.Typ); - Set_Etype (N, Designated_Type (It.Typ)); - - else - Resolve (P, Etype (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. - - Set_Etype (N, Component_Type (Array_Type)); - - 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; - - Eval_Indexed_Component (N); - - 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 - Op : Entity_Id; - Arg1 : Node_Id := Left_Opnd (N); - Arg2 : Node_Id := Right_Opnd (N); - - begin - Op := Entity (N); - - while Scope (Op) /= Standard_Standard loop - Op := Homonym (Op); - pragma Assert (Present (Op)); - end loop; - - Set_Entity (N, Op); - - if Typ /= Etype (Arg1) or else Typ = Etype (Arg2) then - Rewrite (Left_Opnd (N), Convert_To (Typ, Arg1)); - Rewrite (Right_Opnd (N), Convert_To (Typ, Arg2)); - - Analyze (Left_Opnd (N)); - Analyze (Right_Opnd (N)); - end if; - - Resolve_Arithmetic_Op (N, Typ); - end Resolve_Intrinsic_Operator; - - ------------------------ - -- Resolve_Logical_Op -- - ------------------------ - - procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id) is - B_Typ : Entity_Id; - - 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; - 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); - Eval_Logical_Op (N); - 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 - 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); - 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 - begin - -- For now allow circumvention of the restriction against - -- anonymous null access values via a debug switch to allow - -- for easier transition. - - if 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 msg - - if Nkind (Parent (N)) = N_Procedure_Call_Statement - or else - Nkind (Parent (N)) = 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; - - -- 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 - Btyp : constant Entity_Id := Base_Type (Typ); - Op1 : constant Node_Id := Left_Opnd (N); - Op2 : constant Node_Id := Right_Opnd (N); - - procedure Resolve_Concatenation_Arg (Arg : Node_Id; Is_Comp : Boolean); - -- Internal procedure 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. - - ------------------------------- - -- Resolve_Concatenation_Arg -- - ------------------------------- - - procedure Resolve_Concatenation_Arg (Arg : Node_Id; Is_Comp : Boolean) is - 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 - Error_Msg_N ("ambiguous operand for concatenation!", Arg); - - declare - I : Interp_Index; - It : Interp; - - begin - Get_First_Interp (Arg, I, It); - - while Present (It.Nam) loop - - if Base_Type (Etype (It.Nam)) = Base_Type (Typ) - or else Base_Type (Etype (It.Nam)) = - Base_Type (Component_Type (Typ)) - then - Error_Msg_Sloc := Sloc (It.Nam); - Error_Msg_N ("\possible interpretation#", Arg); - end if; - - Get_Next_Interp (I, It); - end loop; - end; - end if; - - Resolve (Arg, Component_Type (Typ)); - - 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_Concatenation_Arg; - - -- Start of processing for Resolve_Op_Concat - - begin - Set_Etype (N, Btyp); - - if Is_Limited_Composite (Btyp) then - Error_Msg_N ("concatenation not available for limited array", N); - end if; - - -- If the operands are themselves concatenations, resolve them as - -- such directly. This removes several layers of recursion and allows - -- GNAT to handle larger multiple concatenations. - - if Nkind (Op1) = N_Op_Concat - and then not Is_Array_Type (Component_Type (Typ)) - and then Entity (Op1) = Entity (N) - then - Resolve_Op_Concat (Op1, Typ); - else - Resolve_Concatenation_Arg - (Op1, Is_Component_Left_Opnd (N)); - end if; - - if Nkind (Op2) = N_Op_Concat - and then not Is_Array_Type (Component_Type (Typ)) - and then Entity (Op2) = Entity (N) - then - Resolve_Op_Concat (Op2, Typ); - else - Resolve_Concatenation_Arg - (Op2, Is_Component_Right_Opnd (N)); - end if; - - Generate_Operator_Reference (N); - - 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) insure 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; - - ---------------------- - -- 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 exponentation 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 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); - 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 - Set_Do_Overflow_Check (N, True); - 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. - - 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; - - if not Valid_Boolean_Arg (Typ) then - Error_Msg_N ("invalid operand type for operator&", N); - Set_Etype (N, Any_Type); - return; - - 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; - - else - if not Is_Boolean_Type (Typ) - and then Parent_Is_Boolean - then - Error_Msg_N ("?not expression should be parenthesized here", N); - end if; - - Resolve (Right_Opnd (N), B_Typ); - Check_Unset_Reference (Right_Opnd (N)); - Set_Etype (N, B_Typ); - Generate_Operator_Reference (N); - 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 - begin - null; - end Resolve_Operator_Symbol; - - ---------------------------------- - -- Resolve_Qualified_Expression -- - ---------------------------------- - - procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id) is - 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. - - if Is_Class_Wide_Type (Target_Typ) - 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); - - 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; - - -- 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 Is_Volatile (Entity (P)) then - Note_Possible_Modification (P); - 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 - 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; - - if Scope (Comp1) /= It1.Typ then - - -- Resolution chooses the new interpretation. - -- Find the component with the right name. - - Comp1 := First_Entity (It1.Typ); - - 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 (S, Comp1); - - else - -- Resolve prefix with its type. - - Resolve (P, T); - end if; - - -- Deal with access type case - - if Is_Access_Type (Etype (P)) then - Apply_Access_Check (N); - T := Designated_Type (Etype (P)); - else - T := Etype (P); - end if; - - if Has_Discriminants (T) - 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 - 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); - 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_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); - - 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); - 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. - - if not Is_Entity_Name (Drange) then - Index := First_Index (Array_Type); - Resolve (Drange, Base_Type (Etype (Index))); - - if Nkind (Drange) = N_Range then - Apply_Range_Check (Drange, Etype (Index)); - end if; - end if; - - Set_Slice_Subtype (N); - 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 - 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 Nkind (Original_Node (N)) /= N_Character_Literal - and then Nkind (Original_Node (N)) /= N_Attribute_Reference - and then Nkind (Original_Node (N)) /= N_Qualified_Expression - and then Nkind (Original_Node (N)) /= 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 tranform the string - -- literal into a full fledged aggregate. - - elsif Is_Bit_Packed_Array (Typ) then - null; - - -- Deal with cases of Wide_String and String - - else - -- For Standard.Wide_String, or any other type whose component - -- type is Standard.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_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 String. - - -- 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 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. - - 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 R_Typ = Standard_Wide_Character - or else R_Typ = Standard_Character - 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?", - 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 : 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, Name_Find, 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 - Target_Type : constant Entity_Id := Etype (N); - Conv_OK : constant Boolean := Conversion_OK (N); - Operand : Node_Id; - Opnd_Type : Entity_Id; - Rop : Node_Id; - - begin - Operand := Expression (N); - - if not Conv_OK - and then not Valid_Conversion (N, Target_Type, 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 (Operand) = N_Op_Multiply - or else Nkind (Operand) = N_Op_Divide) - and then (Etype (Right_Opnd (Operand)) = Universal_Real - or else Etype (Left_Opnd (Operand)) = Universal_Real) - then - if Unique_Fixed_Point_Type (N) = Any_Type then - return; -- expression is ambiguous. - else - Set_Etype (Operand, Standard_Duration); - end if; - - 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, Standard_Long_Long_Float); - - if Realval (Rop) /= Ureal_0 - and then abs (Realval (Rop)) < Delta_Value (Standard_Duration) - then - Error_Msg_N ("universal real operand can only be interpreted?", - Rop); - Error_Msg_N ("\as Duration, and will lose precision?", Rop); - end if; - - else - Error_Msg_N ("invalid context for mixed mode operation", N); - Set_Etype (Operand, Any_Type); - return; - end if; - end if; - - Opnd_Type := Etype (Operand); - Resolve (Operand, Opnd_Type); - - -- 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); - - -- 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_Type)) - and then Target_Type /= Universal_Fixed - and then Opnd_Type /= Universal_Fixed - then - Apply_Type_Conversion_Checks (N); - end if; - - -- Issue warning for conversion of simple object to its own type - - if Warn_On_Redundant_Constructs - and then Comes_From_Source (N) - and then Nkind (N) = N_Type_Conversion - and then Is_Entity_Name (Expression (N)) - and then Etype (Entity (Expression (N))) = Target_Type - then - Error_Msg_NE - ("?useless conversion, & has this type", - N, Entity (Expression (N))); - end if; - end Resolve_Type_Conversion; - - ---------------------- - -- Resolve_Unary_Op -- - ---------------------- - - procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id) is - B_Typ : Entity_Id := Base_Type (Typ); - R : constant Node_Id := Right_Opnd (N); - - begin - -- Generate warning for expressions like -5 mod 3 - - if Paren_Count (N) = 0 - and then Nkind (N) = N_Op_Minus - and then Nkind (Right_Opnd (N)) = N_Op_Mod - then - Error_Msg_N - ("?unary minus expression should be parenthesized here", N); - end if; - - 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); - Check_Unset_Reference (R); - Generate_Operator_Reference (N); - 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 - Set_Do_Overflow_Check (N, True); - end if; - end if; - - 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 - 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 : Source_Ptr := Sloc (N); - Actuals : 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) is - Nam : constant Name_Id := Chars (Op); - Is_Binary : constant Boolean := Nkind (N) in N_Binary_Op; - Op_Node : Node_Id; - - begin - if Chars (N) /= Nam then - - -- Rewrite the operator node using the real operator, not its - -- renaming. - - 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)); - - Generate_Reference (Op, N); - - if Is_Binary then - Set_Left_Opnd (Op_Node, Left_Opnd (N)); - end if; - - Rewrite (N, Op_Node); - 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 : Node_Id; - Index_List : List_Id := New_List; - 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_Component_Type (Slice_Subtype, Component_Type (Etype (N))); - Set_First_Index (Slice_Subtype, Index); - Set_Etype (Slice_Subtype, Base_Type (Etype (N))); - Set_Is_Constrained (Slice_Subtype, True); - Init_Size_Align (Slice_Subtype); - - 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. - - if Is_Packed (Slice_Subtype) and not In_Default_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 - Subtype_Id : Entity_Id; - - begin - if Nkind (N) /= N_String_Literal then - return; - - else - Subtype_Id := Create_Itype (E_String_Literal_Subtype, N); - end if; - - Set_Component_Type (Subtype_Id, Component_Type (Typ)); - 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); - - -- 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 necssary - -- from the length and the low bound. - - Set_String_Literal_Low_Bound - (Subtype_Id, Type_Low_Bound (Etype (First_Index (Typ)))); - - Set_Etype (N, Subtype_Id); - end Set_String_Literal_Subtype; - - ----------------------------- - -- 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. - - 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; - - begin - -- The operations on Duration are visible, so Duration is always a - -- possible interpretation. - - T1 := Standard_Duration; - - Scop := Current_Scope; - - -- Look for fixed-point types in enclosing scopes. - - 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 : 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 - - ---------------------- - -- 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_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 - -- 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"); - 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. - - Get_First_Interp (Operand, I, It); - - while Present (It.Typ) loop - - if It.Typ = Standard_Void_Type then - Remove_Interp (I); - end if; - - Get_Next_Interp (I, It); - end loop; - - 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; - - if Chars (Current_Scope) = Name_Unchecked_Conversion then - - -- This check is dubious, what if there were a user defined - -- scope whose name was Unchecked_Conversion ??? - - return True; - - elsif Is_Numeric_Type (Target_Type) then - if Opnd_Type = Universal_Fixed then - return True; - else - return Conversion_Check (Is_Numeric_Type (Opnd_Type), - "illegal operand for numeric conversion"); - end if; - - 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; - - elsif Number_Dimensions (Target_Type) /= - Number_Dimensions (Opnd_Type) - then - Error_Msg_N - ("incompatible number of dimensions for conversion", Operand); - return False; - - else - declare - Target_Index : Node_Id := First_Index (Target_Type); - Opnd_Index : Node_Id := First_Index (Opnd_Type); - - Target_Index_Type : Entity_Id; - Opnd_Index_Type : Entity_Id; - - Target_Comp_Type : Entity_Id := Component_Type (Target_Type); - Opnd_Comp_Type : Entity_Id := Component_Type (Opnd_Type); - - begin - while Present (Target_Index) and then Present (Opnd_Index) loop - Target_Index_Type := Etype (Target_Index); - Opnd_Index_Type := Etype (Opnd_Index); - - 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 Base_Type (Target_Comp_Type) /= - Base_Type (Opnd_Comp_Type) - then - Error_Msg_N - ("incompatible component types for array conversion", - Operand); - return False; - - elsif - Is_Constrained (Target_Comp_Type) - /= Is_Constrained (Opnd_Comp_Type) - or else 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; - end if; - - return True; - - 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 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; - - elsif Ekind (Opnd_Type) = E_Anonymous_Access_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 type declaration (which will appear - -- as a discriminal) is always illegal because the - -- level of the discriminant is considered to be - -- deeper than any (namable) 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 - Target : constant Entity_Id := Designated_Type (Target_Type); - Opnd : constant Entity_Id := Designated_Type (Opnd_Type); - - begin - if Is_Tagged_Type (Target) then - return Valid_Tagged_Conversion (Target, Opnd); - - else - if Base_Type (Target) /= Base_Type (Opnd) then - Error_Msg_NE - ("target designated type not compatible with }", - N, Base_Type (Opnd)); - return False; - - elsif not Subtypes_Statically_Match (Target, Opnd) - and then (not Has_Discriminants (Target) - or else Is_Constrained (Target)) - then - Error_Msg_NE - ("target designated subtype not compatible with }", - N, Opnd); - return False; - - else - return True; - end if; - end if; - end; - - elsif Ekind (Target_Type) = E_Access_Subprogram_Type - and then Conversion_Check - (Ekind (Base_Type (Opnd_Type)) = E_Access_Subprogram_Type, - "illegal operand for access subprogram conversion") - then - -- Check that the designated types are subtype conformant - - if not Subtype_Conformant (Designated_Type (Opnd_Type), - Designated_Type (Target_Type)) - then - Error_Msg_N - ("operand type is not subtype conformant with target type", - Operand); - end if; - - -- 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 := - Enclosing_Generic_Body (Target_Type); - - begin - 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; - - 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; - - elsif Is_Tagged_Type (Target_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, there may be inconsistent views of the same - -- type, or types derived from the same type. - - elsif In_Instance - and then Underlying_Type (Target_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;