X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fsem_res.adb;h=96a295cd218b6c56f9ca3b8eb100bd6e244776f0;hb=17052c8f8f63239deccec6d06ff1d9a9ebfc4640;hp=25be7c94376fff7210a7f2c076da94cdec29a39a;hpb=f27cea3abf8ded22456f5f46a812cc3915969815;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 25be7c94376..96a295cd218 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6,18 +6,17 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -29,12 +28,15 @@ with Checks; use Checks; with Debug; use Debug; with Debug_A; use Debug_A; with Einfo; use Einfo; +with Elists; use Elists; with Errout; use Errout; with Expander; use Expander; with Exp_Disp; use Exp_Disp; +with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; +with Fname; use Fname; with Freeze; use Freeze; with Itypes; use Itypes; with Lib; use Lib; @@ -48,14 +50,17 @@ with Restrict; use Restrict; with Rident; use Rident; with Rtsfind; use Rtsfind; with Sem; use Sem; +with Sem_Aux; use Sem_Aux; with Sem_Aggr; use Sem_Aggr; with Sem_Attr; use Sem_Attr; with Sem_Cat; use Sem_Cat; with Sem_Ch4; use Sem_Ch4; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; +with Sem_Ch13; use Sem_Ch13; with Sem_Disp; use Sem_Disp; with Sem_Dist; use Sem_Dist; +with Sem_Elim; use Sem_Elim; with Sem_Elab; use Sem_Elab; with Sem_Eval; use Sem_Eval; with Sem_Intr; use Sem_Intr; @@ -66,7 +71,7 @@ with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; -with Targparm; use Targparm; +with Style; use Style; with Tbuild; use Tbuild; with Uintp; use Uintp; with Urealp; use Urealp; @@ -86,15 +91,6 @@ package body Sem_Res is -- 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_Direct_Boolean_Op (N : Node_Id); - -- N is a binary operator node which may possibly operate on Boolean - -- operands. If the operator does have Boolean operands, then a call is - -- made to check the restriction No_Direct_Boolean_Operators. - 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). @@ -105,6 +101,11 @@ package body Sem_Res is -- universal must be checked for visibility during resolution -- because their type is not determinable based on their operands. + procedure Check_Fully_Declared_Prefix + (Typ : Entity_Id; + Pref : Node_Id); + -- Check that the type of the prefix of a dereference is not incomplete + function Check_Infinite_Recursion (N : Node_Id) return Boolean; -- Given a call node, N, which is known to occur immediately within the -- subprogram being called, determines whether it is a detectable case of @@ -118,6 +119,16 @@ package body Sem_Res is -- initialization of individual components within the init proc itself. -- Could be optimized away perhaps? + procedure Check_No_Direct_Boolean_Operators (N : Node_Id); + -- N is the node for a logical operator. If the operator is predefined, and + -- the root type of the operands is Standard.Boolean, then a check is made + -- for restriction No_Direct_Boolean_Operators. This procedure also handles + -- the style check for Style_Check_Boolean_And_Or. + + function Is_Definite_Access_Type (E : Entity_Id) return Boolean; + -- Determine whether E is an access type declared by an access + -- declaration, and not an (anonymous) allocator type. + function Is_Predefined_Op (Nam : Entity_Id) return Boolean; -- Utility to check whether the name in the call is a predefined -- operator, in which case the call is made into an operator node. @@ -129,6 +140,23 @@ package body Sem_Res is -- of the task, it must be replaced with a reference to the discriminant -- of the task being called. + procedure Resolve_Op_Concat_Arg + (N : Node_Id; + Arg : Node_Id; + Typ : Entity_Id; + Is_Comp : Boolean); + -- Internal procedure for Resolve_Op_Concat to resolve one operand of + -- concatenation operator. The operand is either of the array type or of + -- the component type. If the operand is an aggregate, and the component + -- type is composite, this is ambiguous if component type has aggregates. + + procedure Resolve_Op_Concat_First (N : Node_Id; Typ : Entity_Id); + -- Does the first part of the work of Resolve_Op_Concat + + procedure Resolve_Op_Concat_Rest (N : Node_Id; Typ : Entity_Id); + -- Does the "rest" of the work of Resolve_Op_Concat, after the left operand + -- has been resolved. See Resolve_Op_Concat for details. + procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id); procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id); procedure Resolve_Call (N : Node_Id; Typ : Entity_Id); @@ -215,6 +243,11 @@ package body Sem_Res is procedure Set_Slice_Subtype (N : Node_Id); -- Build subtype of array type, with the range specified by the slice + procedure Simplify_Type_Conversion (N : Node_Id); + -- Called after N has been resolved and evaluated, but before range checks + -- have been applied. Currently simplifies a combination of floating-point + -- to integer conversion and Truncation attribute. + function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id; -- A universal_fixed expression in an universal context is unambiguous -- if there is only one applicable fixed point type. Determining whether @@ -240,18 +273,28 @@ package body Sem_Res is 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); + -- First the ones in Standard - if Present (E) then + Error_Msg_N + ("\\possible interpretation: Character!", C); + Error_Msg_N + ("\\possible interpretation: Wide_Character!", C); - while Present (E) loop - Error_Msg_NE ("\possible interpretation:}!", C, Etype (E)); - E := Homonym (E); - end loop; + -- Include Wide_Wide_Character in Ada 2005 mode + + if Ada_Version >= Ada_05 then + Error_Msg_N + ("\\possible interpretation: Wide_Wide_Character!", C); end if; + + -- Now any other types that match + + E := Current_Entity (C); + while Present (E) loop + Error_Msg_NE ("\\possible interpretation:}!", C, Etype (E)); + E := Homonym (E); + end loop; end if; end Ambiguous_Character; @@ -284,7 +327,6 @@ package body Sem_Res is if Suppress = All_Checks then declare Svg : constant Suppress_Array := Scope_Suppress; - begin Scope_Suppress := (others => True); Analyze_And_Resolve (N, Typ); @@ -326,7 +368,6 @@ package body Sem_Res is if Suppress = All_Checks then declare Svg : constant Suppress_Array := Scope_Suppress; - begin Scope_Suppress := (others => True); Analyze_And_Resolve (N); @@ -352,19 +393,6 @@ package body Sem_Res is end if; end Analyze_And_Resolve; - ----------------------------- - -- Check_Direct_Boolean_Op -- - ----------------------------- - - procedure Check_Direct_Boolean_Op (N : Node_Id) is - begin - if Nkind (N) in N_Op - and then Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean - then - Check_Restriction (No_Direct_Boolean_Operators, N); - end if; - end Check_Direct_Boolean_Op; - ---------------------------- -- Check_Discriminant_Use -- ---------------------------- @@ -376,9 +404,9 @@ package body Sem_Res is D : Node_Id; begin - -- Any use in a default expression is legal + -- Any use in a spec-expression is legal - if In_Default_Expression then + if In_Spec_Expression then null; elsif Nkind (PN) = N_Range then @@ -415,10 +443,9 @@ package body Sem_Res is and then Scope (Disc) = Current_Scope and then not (Nkind (Parent (P)) = N_Subtype_Indication - and then - (Nkind (Parent (Parent (P))) = N_Component_Definition - or else - Nkind (Parent (Parent (P))) = N_Subtype_Declaration) + and then + Nkind_In (Parent (Parent (P)), N_Component_Definition, + N_Subtype_Declaration) and then Paren_Count (N) = 0) then Error_Msg_N @@ -426,16 +453,18 @@ package body Sem_Res is return; end if; - -- Detect a common beginner error: + -- Detect a common error: -- type R (D : Positive := 100) is record -- Name : String (1 .. D); -- end record; - -- The default value causes an object of type R to be - -- allocated with room for Positive'Last characters. + -- The default value causes an object of type R to be allocated + -- with room for Positive'Last characters. The RM does not mandate + -- the allocation of the maximum size, but that is what GNAT does + -- so we should warn the programmer that there is a problem. - declare + Check_Large : declare SI : Node_Id; T : Entity_Id; TB : Node_Id; @@ -452,14 +481,19 @@ package body Sem_Res is 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; + -- The type is considered large if its bounds are known at + -- compile time and if it requires at least as many bits as + -- a Positive to store the possible values. + + return Compile_Time_Known_Value (Type_Low_Bound (T)) + and then Compile_Time_Known_Value (Type_High_Bound (T)) + and then + Minimum_Size (T, Biased => True) >= + RM_Size (Standard_Positive); end Large_Storage_Type; + -- Start of processing for Check_Large + begin -- Check that the Disc has a large range @@ -478,7 +512,7 @@ package body Sem_Res is -- Check that it is the high bound if N /= High_Bound (PN) - or else not Present (Discriminant_Default_Value (Disc)) + or else No (Discriminant_Default_Value (Disc)) then goto No_Danger; end if; @@ -524,19 +558,19 @@ package body Sem_Res is -- Warn about the danger Error_Msg_N - ("creation of & object may raise Storage_Error?", + ("?creation of & object may raise Storage_Error!", Scope (Disc)); <> null; - end; + end Check_Large; 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 + elsif Nkind_In (PN, N_Index_Or_Discriminant_Constraint, + N_Discriminant_Association) then if Paren_Count (N) > 0 then Error_Msg_N @@ -557,10 +591,9 @@ package body Sem_Res is 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 + while not Nkind_In (P, N_Component_Declaration, + N_Subtype_Indication, + N_Entry_Declaration) loop D := P; P := Parent (P); @@ -573,10 +606,8 @@ package body Sem_Res is -- is of course a double fault. if (Nkind (P) = N_Subtype_Indication - and then - (Nkind (Parent (P)) = N_Component_Definition - or else - Nkind (Parent (P)) = N_Derived_Type_Definition) + and then Nkind_In (Parent (P), N_Component_Definition, + N_Derived_Type_Definition) and then D = Constraint (P)) -- The constraint itself may be given by a subtype indication, @@ -607,6 +638,55 @@ package body Sem_Res is end if; end Check_For_Visible_Operator; + ---------------------------------- + -- Check_Fully_Declared_Prefix -- + ---------------------------------- + + procedure Check_Fully_Declared_Prefix + (Typ : Entity_Id; + Pref : Node_Id) + is + begin + -- Check that the designated type of the prefix of a dereference is + -- not an incomplete type. This cannot be done unconditionally, because + -- dereferences of private types are legal in default expressions. This + -- case is taken care of in Check_Fully_Declared, called below. There + -- are also 2005 cases where it is legal for the prefix to be unfrozen. + + -- This consideration also applies to similar checks for allocators, + -- qualified expressions, and type conversions. + + -- An additional exception concerns other per-object expressions that + -- are not directly related to component declarations, in particular + -- representation pragmas for tasks. These will be per-object + -- expressions if they depend on discriminants or some global entity. + -- If the task has access discriminants, the designated type may be + -- incomplete at the point the expression is resolved. This resolution + -- takes place within the body of the initialization procedure, where + -- the discriminant is replaced by its discriminal. + + if Is_Entity_Name (Pref) + and then Ekind (Entity (Pref)) = E_In_Parameter + then + null; + + -- Ada 2005 (AI-326): Tagged incomplete types allowed. The wrong usages + -- are handled by Analyze_Access_Attribute, Analyze_Assignment, + -- Analyze_Object_Renaming, and Freeze_Entity. + + elsif Ada_Version >= Ada_05 + and then Is_Entity_Name (Pref) + and then Is_Access_Type (Etype (Pref)) + and then Ekind (Directly_Designated_Type (Etype (Pref))) = + E_Incomplete_Type + and then Is_Tagged_Type (Directly_Designated_Type (Etype (Pref))) + then + null; + else + Check_Fully_Declared (Typ, Parent (Pref)); + end if; + end Check_Fully_Declared_Prefix; + ------------------------------ -- Check_Infinite_Recursion -- ------------------------------ @@ -654,28 +734,68 @@ package body Sem_Res is -- Start of processing for Check_Infinite_Recursion begin - -- Loop moving up tree, quitting if something tells us we are - -- definitely not in an infinite recursion situation. + -- Special case, if this is a procedure call and is a call to the + -- current procedure with the same argument list, then this is for + -- sure an infinite recursion and we insert a call to raise SE. + + if Is_List_Member (N) + and then List_Length (List_Containing (N)) = 1 + and then Same_Argument_List + then + declare + P : constant Node_Id := Parent (N); + begin + if Nkind (P) = N_Handled_Sequence_Of_Statements + and then Nkind (Parent (P)) = N_Subprogram_Body + and then Is_Empty_List (Declarations (Parent (P))) + then + Error_Msg_N ("!?infinite recursion", N); + Error_Msg_N ("\!?Storage_Error will be raised at run time", N); + Insert_Action (N, + Make_Raise_Storage_Error (Sloc (N), + Reason => SE_Infinite_Recursion)); + return True; + end if; + end; + end if; + + -- If not that special case, search up tree, quitting if we reach a + -- construct (e.g. a conditional) that tells us that this is not a + -- case for an infinite recursion warning. C := N; loop P := Parent (C); + + -- If no parent, then we were not inside a subprogram, this can for + -- example happen when processing certain pragmas in a spec. Just + -- return False in this case. + + if No (P) then + return False; + end if; + + -- Done if we get to subprogram body, this is definitely an infinite + -- recursion case if we did not find anything to stop us. + exit when Nkind (P) = N_Subprogram_Body; - if 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 + -- If appearing in conditional, result is false + + if Nkind_In (P, N_Or_Else, + N_And_Then, + N_If_Statement, + N_Case_Statement) then return False; elsif Nkind (P) = N_Handled_Sequence_Of_Statements and then C /= First (Statements (P)) then - -- If the call is the expression of a return statement and - -- the actuals are identical to the formals, it's worth a - -- warning. However, we skip this if there is an immediately - -- preceding raise statement, since the call is never executed. + -- If the call is the expression of a return statement and the + -- actuals are identical to the formals, it's worth a warning. + -- However, we skip this if there is an immediately preceding + -- raise statement, since the call is never executed. -- Furthermore, this corresponds to a common idiom: @@ -687,15 +807,33 @@ package body Sem_Res is -- for generating a stub function - if Nkind (Parent (N)) = N_Return_Statement + if Nkind (Parent (N)) = N_Simple_Return_Statement and then Same_Argument_List then - exit when not Is_List_Member (Parent (N)) - or else (Nkind (Prev (Parent (N))) /= N_Raise_Statement - and then - (Nkind (Prev (Parent (N))) not in N_Raise_xxx_Error - or else - Present (Condition (Prev (Parent (N)))))); + exit when not Is_List_Member (Parent (N)); + + -- OK, return statement is in a statement list, look for raise + + declare + Nod : Node_Id; + + begin + -- Skip past N_Freeze_Entity nodes generated by expansion + + Nod := Prev (Parent (N)); + while Present (Nod) + and then Nkind (Nod) = N_Freeze_Entity + loop + Prev (Nod); + end loop; + + -- If no raise statement, give warning + + exit when Nkind (Nod) /= N_Raise_Statement + and then + (Nkind (Nod) not in N_Raise_xxx_Error + or else Present (Condition (Nod))); + end; end if; return False; @@ -705,8 +843,8 @@ package body Sem_Res is end if; end loop; - Error_Msg_N ("possible infinite recursion?", N); - Error_Msg_N ("\Storage_Error may be raised at run time?", N); + Error_Msg_N ("!?possible infinite recursion", N); + Error_Msg_N ("\!?Storage_Error may be raised at run time", N); return True; end Check_Infinite_Recursion; @@ -721,7 +859,7 @@ package body Sem_Res is function Uses_SS (T : Entity_Id) return Boolean; -- Check whether the creation of an object of the type will involve -- use of the secondary stack. If T is a record type, this is true - -- if the expression for some component uses the secondary stack, eg. + -- if the expression for some component uses the secondary stack, e.g. -- through a call to a function that returns an unconstrained value. -- False if T is controlled, because cleanups occur elsewhere. @@ -730,31 +868,42 @@ package body Sem_Res is ------------- function Uses_SS (T : Entity_Id) return Boolean is - Comp : Entity_Id; - Expr : Node_Id; + Comp : Entity_Id; + Expr : Node_Id; + Full_Type : Entity_Id := Underlying_Type (T); begin - if Is_Controlled (T) then - return False; + -- Normally we want to use the underlying type, but if it's not set + -- then continue with T. - elsif Is_Array_Type (T) then - return Uses_SS (Component_Type (T)); + if not Present (Full_Type) then + Full_Type := T; + end if; + + if Is_Controlled (Full_Type) then + return False; - elsif Is_Record_Type (T) then - Comp := First_Component (T); + elsif Is_Array_Type (Full_Type) then + return Uses_SS (Component_Type (Full_Type)); + elsif Is_Record_Type (Full_Type) then + Comp := First_Component (Full_Type); while Present (Comp) loop - if Ekind (Comp) = E_Component and then Nkind (Parent (Comp)) = N_Component_Declaration then - Expr := Expression (Parent (Comp)); + -- The expression for a dynamic component may be rewritten + -- as a dereference, so retrieve original node. - -- The expression for a dynamic component may be - -- rewritten as a dereference. Retrieve original - -- call. + Expr := Original_Node (Expression (Parent (Comp))); - if Nkind (Original_Node (Expr)) = N_Function_Call + -- Return True if the expression is a call to a function + -- (including an attribute function such as Image) with + -- a result that requires a transient scope. + + if (Nkind (Expr) = N_Function_Call + or else (Nkind (Expr) = N_Attribute_Reference + and then Present (Expressions (Expr)))) and then Requires_Transient_Scope (Etype (Expr)) then return True; @@ -777,19 +926,34 @@ package body Sem_Res is -- Start of processing for Check_Initialization_Call begin - -- Nothing to do if functions do not use the secondary stack for - -- returns (i.e. they use a depressed stack pointer instead). - - if Functions_Return_By_DSP_On_Target then - return; - - -- Otherwise establish a transient scope if the type needs it + -- Establish a transient scope if the type needs it - elsif Uses_SS (Typ) then + if Uses_SS (Typ) then Establish_Transient_Scope (First_Actual (N), Sec_Stack => True); end if; end Check_Initialization_Call; + --------------------------------------- + -- Check_No_Direct_Boolean_Operators -- + --------------------------------------- + + procedure Check_No_Direct_Boolean_Operators (N : Node_Id) is + begin + if Scope (Entity (N)) = Standard_Standard + and then Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean + then + -- Restriction only applies to original source code + + if Comes_From_Source (N) then + Check_Restriction (No_Direct_Boolean_Operators, N); + end if; + end if; + + if Style_Check then + Check_Boolean_Operator (N); + end if; + end Check_No_Direct_Boolean_Operators; + ------------------------------ -- Check_Parameterless_Call -- ------------------------------ @@ -848,33 +1012,32 @@ package body Sem_Res is Require_Entity (N); end if; - -- If the context expects a value, and the name is a procedure, - -- this is most likely a missing 'Access. Do not try to resolve - -- the parameterless call, error will be caught when the outer - -- call is analyzed. + -- If the context expects a value, and the name is a procedure, this is + -- most likely a missing 'Access. Don't try to resolve the parameterless + -- call, error will be caught when the outer call is analyzed. if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Procedure and then not Is_Overloaded (N) and then - (Nkind (Parent (N)) = N_Parameter_Association - or else Nkind (Parent (N)) = N_Function_Call - or else Nkind (Parent (N)) = N_Procedure_Call_Statement) + Nkind_In (Parent (N), N_Parameter_Association, + N_Function_Call, + N_Procedure_Call_Statement) then return; end if; - -- Rewrite as call if overloadable entity that is (or could be, in - -- the overloaded case) a function call. If we know for sure that - -- the entity is an enumeration literal, we do not rewrite it. + -- 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 + -- Rewrite as call if it is an explicit dereference of an expression of + -- a subprogram access type, and the subprogram type is not that of a -- procedure or entry. or else @@ -921,6 +1084,18 @@ package body Sem_Res is end if; end Check_Parameterless_Call; + ----------------------------- + -- Is_Definite_Access_Type -- + ----------------------------- + + function Is_Definite_Access_Type (E : Entity_Id) return Boolean is + Btyp : constant Entity_Id := Base_Type (E); + begin + return Ekind (Btyp) = E_Access_Type + or else (Ekind (Btyp) = E_Access_Subprogram_Type + and then Comes_From_Source (Btyp)); + end Is_Definite_Access_Type; + ---------------------- -- Is_Predefined_Op -- ---------------------- @@ -956,10 +1131,6 @@ package body Sem_Res is 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 @@ -969,18 +1140,6 @@ package body Sem_Res is -- 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 -- --------------------------- @@ -996,9 +1155,7 @@ package body Sem_Res is else Get_First_Interp (Nod, I, It); - while Present (It.Typ) loop - if Scope (Base_Type (It.Typ)) = S then return True; end if; @@ -1066,9 +1223,7 @@ package body Sem_Res is else E := First_Entity (Pack); - while Present (E) loop - if Test (E) and then not In_Decl then @@ -1135,6 +1290,13 @@ package body Sem_Res is then null; + -- Visibility does not need to be checked in an instance: if the + -- operator was not visible in the generic it has been diagnosed + -- already, else there is an implicit copy of it in the instance. + + elsif In_Instance then + null; + elsif (Op_Name = Name_Op_Multiply or else Op_Name = Name_Op_Divide) and then Is_Fixed_Point_Type (Etype (Left_Opnd (Op_Node))) @@ -1144,6 +1306,15 @@ package body Sem_Res is Error := True; end if; + -- Ada 2005, AI-420: Predefined equality on Universal_Access + -- is available. + + elsif Ada_Version >= Ada_05 + and then (Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne) + and then Ekind (Etype (Act1)) = E_Anonymous_Access_Type + then + null; + else Opnd_Type := Base_Type (Etype (Right_Opnd (Op_Node))); @@ -1263,7 +1434,19 @@ package body Sem_Res is Set_Entity (Op_Node, Op_Id); Generate_Reference (Op_Id, N, ' '); - Rewrite (N, Op_Node); + + -- Do rewrite setting Comes_From_Source on the result if the original + -- call came from source. Although it is not strictly the case that the + -- operator as such comes from the source, logically it corresponds + -- exactly to the function call in the source, so it should be marked + -- this way (e.g. to make sure that validity checks work fine). + + declare + CS : constant Boolean := Comes_From_Source (N); + begin + Rewrite (N, Op_Node); + Set_Comes_From_Source (N, CS); + end; -- If this is an arithmetic operator and the result type is private, -- the operands and the result must be wrapped in conversion to @@ -1307,23 +1490,40 @@ package body Sem_Res is 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; + 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; @@ -1331,10 +1531,14 @@ package body Sem_Res is -- 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; + 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; @@ -1343,11 +1547,11 @@ package body Sem_Res is return Kind; end Operator_Kind; - ----------------------------- - -- Pre_Analyze_And_Resolve -- - ----------------------------- + ---------------------------- + -- Preanalyze_And_Resolve -- + ---------------------------- - procedure Pre_Analyze_And_Resolve (N : Node_Id; T : Entity_Id) is + procedure Preanalyze_And_Resolve (N : Node_Id; T : Entity_Id) is Save_Full_Analysis : constant Boolean := Full_Analysis; begin @@ -1362,11 +1566,11 @@ package body Sem_Res is Expander_Mode_Restore; Full_Analysis := Save_Full_Analysis; - end Pre_Analyze_And_Resolve; + end Preanalyze_And_Resolve; -- Version without context type - procedure Pre_Analyze_And_Resolve (N : Node_Id) is + procedure Preanalyze_And_Resolve (N : Node_Id) is Save_Full_Analysis : constant Boolean := Full_Analysis; begin @@ -1378,7 +1582,7 @@ package body Sem_Res is Expander_Mode_Restore; Full_Analysis := Save_Full_Analysis; - end Pre_Analyze_And_Resolve; + end Preanalyze_And_Resolve; ---------------------------------- -- Replace_Actual_Discriminants -- @@ -1445,16 +1649,21 @@ package body Sem_Res is ------------- procedure Resolve (N : Node_Id; Typ : Entity_Id) is + Ambiguous : Boolean := False; + Ctx_Type : Entity_Id := Typ; + Expr_Type : Entity_Id := Empty; -- prevent junk warning + Err_Type : Entity_Id := Empty; + Found : Boolean := False; + From_Lib : Boolean; I : Interp_Index; - I1 : Interp_Index := 0; -- prevent junk warning + 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 - Err_Type : Entity_Id := Empty; - Ambiguous : Boolean := False; + + function Comes_From_Predefined_Lib_Unit (Nod : Node_Id) return Boolean; + -- Determine whether a node comes from a predefined library unit or + -- Standard. procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id); -- Try and fix up a literal so that it matches its expected type. New @@ -1463,6 +1672,18 @@ package body Sem_Res is procedure Resolution_Failed; -- Called when attempt at resolving current expression fails + ------------------------------------ + -- Comes_From_Predefined_Lib_Unit -- + ------------------------------------- + + function Comes_From_Predefined_Lib_Unit (Nod : Node_Id) return Boolean is + begin + return + Sloc (Nod) = Standard_Location + or else Is_Predefined_File_Name (Unit_File_Name ( + Get_Source_Unit (Sloc (Nod)))); + end Comes_From_Predefined_Lib_Unit; + -------------------- -- Patch_Up_Value -- -------------------- @@ -1486,6 +1707,7 @@ package body Sem_Res is 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 @@ -1547,8 +1769,8 @@ package body Sem_Res is 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) + 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))) @@ -1559,6 +1781,8 @@ package body Sem_Res is ("prefix must statically denote a non-remote subprogram", N); end if; + From_Lib := Comes_From_Predefined_Lib_Unit (N); + -- If the context is a Remote_Access_To_Subprogram, access attributes -- must be resolved with the corresponding fat pointer. There is no need -- to check for the attribute name since the return type of an @@ -1624,6 +1848,7 @@ package body Sem_Res is Old_Id => Designated_Type (Corresponding_Remote_Type (Typ)), Err_Loc => N); + if Is_Remote then Process_Remote_AST_Attribute (N, Typ); end if; @@ -1672,14 +1897,13 @@ package body Sem_Res is -- is compatible with the context (i.e. the type passed to Resolve) else - Get_First_Interp (N, I, It); - -- Loop through possible interpretations + Get_First_Interp (N, I, It); Interp_Loop : while Present (It.Typ) loop -- We are only interested in interpretations that are compatible - -- with the expected type, any other interpretations are ignored + -- with the expected type, any other interpretations are ignored. if not Covers (Typ, It.Typ) then if Debug_Flag_V then @@ -1688,6 +1912,20 @@ package body Sem_Res is end if; else + -- Skip the current interpretation if it is disabled by an + -- abstract operator. This action is performed only when the + -- type against which we are resolving is the same as the + -- type of the interpretation. + + if Ada_Version >= Ada_05 + and then It.Typ = Typ + and then Typ /= Universal_Integer + and then Typ /= Universal_Real + and then Present (It.Abstract_Op) + then + goto Continue; + end if; + -- First matching interpretation if not Found then @@ -1702,6 +1940,16 @@ package body Sem_Res is -- some more obscure cases are handled in Disambiguate. else + -- If the current statement is part of a predefined library + -- unit, then all interpretations which come from user level + -- packages should not be considered. + + if From_Lib + and then not Comes_From_Predefined_Lib_Unit (It.Nam) + then + goto Continue; + end if; + Error_Msg_Sloc := Sloc (Seen); It1 := Disambiguate (N, I1, I, Typ); @@ -1722,14 +1970,15 @@ package body Sem_Res is -- 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 + if Nkind_In (N, N_Function_Call, + N_Procedure_Call_Statement) then declare - A : Node_Id := First_Actual (N); + A : Node_Id; E : Node_Id; begin + A := First_Actual (N); while Present (A) loop E := A; @@ -1750,7 +1999,7 @@ package body Sem_Res is end loop; end; - elsif Nkind (N) in N_Binary_Op + elsif Nkind (N) in N_Binary_Op and then (Etype (Left_Opnd (N)) = Any_Type or else Etype (Right_Opnd (N)) = Any_Type) then @@ -1767,28 +2016,42 @@ package body Sem_Res is -- message only at the start of an ambiguous set. if not Ambiguous then - Error_Msg_NE - ("ambiguous expression (cannot resolve&)!", - N, It.Nam); + if Nkind (N) = N_Function_Call + and then Nkind (Name (N)) = N_Explicit_Dereference + then + Error_Msg_N + ("ambiguous expression " + & "(cannot resolve indirect call)!", N); + else + Error_Msg_NE -- CODEFIX + ("ambiguous expression (cannot resolve&)!", + N, It.Nam); + end if; - Error_Msg_N - ("possible interpretation#!", N); Ambiguous := True; + + if Nkind (Parent (Seen)) = N_Full_Type_Declaration then + Error_Msg_N + ("\\possible interpretation (inherited)#!", N); + else + Error_Msg_N -- CODEFIX + ("\\possible interpretation#!", N); + end if; end if; Error_Msg_Sloc := Sloc (It.Nam); -- By default, the error message refers to the candidate - -- interpretation. But if it is a predefined operator, - -- it is implicitly declared at the declaration of - -- the type of the operand. Recover the sloc of that - -- declaration for the error message. + -- interpretation. But if it is a predefined operator, it + -- is implicitly declared at the declaration of the type + -- of the operand. Recover the sloc of that declaration + -- for the error message. if Nkind (N) in N_Op and then Scope (It.Nam) = Standard_Standard and then not Is_Overloaded (Right_Opnd (N)) - and then Scope (Base_Type (Etype (Right_Opnd (N)))) - /= Standard_Standard + and then Scope (Base_Type (Etype (Right_Opnd (N)))) /= + Standard_Standard then Err_Type := First_Subtype (Etype (Right_Opnd (N))); @@ -1801,8 +2064,8 @@ package body Sem_Res is elsif Nkind (N) in N_Binary_Op and then Scope (It.Nam) = Standard_Standard and then not Is_Overloaded (Left_Opnd (N)) - and then Scope (Base_Type (Etype (Left_Opnd (N)))) - /= Standard_Standard + and then Scope (Base_Type (Etype (Left_Opnd (N)))) /= + Standard_Standard then Err_Type := First_Subtype (Etype (Left_Opnd (N))); @@ -1811,6 +2074,19 @@ package body Sem_Res is then Error_Msg_Sloc := Sloc (Parent (Err_Type)); end if; + + -- If this is an indirect call, use the subprogram_type + -- in the message, to have a meaningful location. + -- Indicate as well if this is an inherited operation, + -- created by a type declaration. + + elsif Nkind (N) = N_Function_Call + and then Nkind (Name (N)) = N_Explicit_Dereference + and then Is_Type (It.Nam) + then + Err_Type := It.Nam; + Error_Msg_Sloc := + Sloc (Associated_Node_For_Itype (Err_Type)); else Err_Type := Empty; end if; @@ -1819,20 +2095,40 @@ package body Sem_Res is and then Scope (It.Nam) = Standard_Standard and then Present (Err_Type) then + -- Special-case the message for universal_fixed + -- operators, which are not declared with the type + -- of the operand, but appear forever in Standard. + + if It.Typ = Universal_Fixed + and then Scope (It.Nam) = Standard_Standard + then + Error_Msg_N + ("\\possible interpretation as " & + "universal_fixed operation " & + "(RM 4.5.5 (19))", N); + else + Error_Msg_N + ("\\possible interpretation (predefined)#!", N); + end if; + + elsif + Nkind (Parent (It.Nam)) = N_Full_Type_Declaration + then Error_Msg_N - ("possible interpretation (predefined)#!", N); + ("\\possible interpretation (inherited)#!", N); else - Error_Msg_N ("possible interpretation#!", N); + Error_Msg_N -- CODEFIX + ("\\possible interpretation#!", N); end if; end if; end if; - -- We have a matching interpretation, Expr_Type is the - -- type from this interpretation, and Seen is the entity. + -- 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. + -- 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); @@ -1841,28 +2137,30 @@ package body Sem_Res is elsif Nkind (N) = N_Character_Literal then Set_Etype (N, Expr_Type); + elsif Nkind (N) = N_Conditional_Expression 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 + -- short-circuit form (which is not an operator node), or call + -- with a name that is an explicit dereference, there is + -- nothing to be done at this point. + + elsif Nkind_In (N, N_Explicit_Dereference, + N_Attribute_Reference, + N_And_Then, + N_Indexed_Component, + N_Or_Else, + N_Range, + N_Selected_Component, + N_Slice) or else Nkind (Name (N)) = N_Explicit_Dereference then null; - -- For procedure or function calls, set the type of the - -- name, and also the entity pointer for the prefix + -- 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) + elsif Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call) and then (Is_Entity_Name (Name (N)) or else Nkind (Name (N)) = N_Operator_Symbol) then @@ -1885,9 +2183,11 @@ package body Sem_Res is end if; + <> + -- Move to next interpretation - exit Interp_Loop when not Present (It.Typ); + exit Interp_Loop when No (It.Typ); Get_Next_Interp (I, It); end loop Interp_Loop; @@ -1901,11 +2201,10 @@ package body Sem_Res is 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 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 @@ -1919,8 +2218,8 @@ package body Sem_Res is ("cannot use function & in a procedure call", Name (N), Entity (Name (N))); - -- Otherwise give general message (not clear what cases - -- this covers, but no harm in providing for them!) + -- Otherwise give general message (not clear what cases this + -- covers, but no harm in providing for them!) else Error_Msg_N ("expect procedure name in procedure call", N); @@ -1930,11 +2229,11 @@ package body Sem_Res is -- 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. + -- 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 @@ -1944,8 +2243,8 @@ package body Sem_Res is 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. + -- 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) @@ -1956,16 +2255,14 @@ package body Sem_Res is 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. + -- 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). + -- 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 @@ -1978,12 +2275,16 @@ package body Sem_Res is 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 + -- Check one aggregate, and set Found to True if we have a + -- definite error in any of its elements procedure Check_Elmt (Aelmt : Node_Id); - -- Check one element of aggregate and set Found to - -- True if we definitely have an error in the element. + -- Check one element of aggregate and set Found to True if + -- we definitely have an error in the element. + + ---------------- + -- Check_Aggr -- + ---------------- procedure Check_Aggr (Aggr : Node_Id) is Elmt : Node_Id; @@ -2000,7 +2301,16 @@ package body Sem_Res is if Present (Component_Associations (Aggr)) then Elmt := First (Component_Associations (Aggr)); while Present (Elmt) loop - Check_Elmt (Expression (Elmt)); + + -- If this is a default-initialized component, then + -- there is nothing to check. The box will be + -- replaced by the appropriate call during late + -- expansion. + + if not Box_Present (Elmt) then + Check_Elmt (Expression (Elmt)); + end if; + Next (Elmt); end loop; end if; @@ -2075,19 +2385,18 @@ package body Sem_Res is It : Interp; begin - Error_Msg_N ("\possible interpretations:", N); - Get_First_Interp (Name (N), Index, It); + 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); - + Error_Msg_Sloc := Sloc (It.Nam); + Error_Msg_Node_2 := It.Nam; + Error_Msg_NE + ("\\ type& for & declared#", N, It.Typ); Get_Next_Interp (Index, It); end loop; end; + else Error_Msg_N ("\use -gnatf for details", N); end if; @@ -2135,7 +2444,7 @@ package body Sem_Res is end if; end if; - -- A user-defined operator is tranformed into a function call at + -- A user-defined operator is transformed into a function call at -- this point, so that further processing knows that operators are -- really operators (i.e. are predefined operators). User-defined -- operators that are intrinsic are just renamings of the predefined @@ -2154,8 +2463,8 @@ package body Sem_Res is elsif Present (Alias (Entity (N))) and then - Nkind (Parent (Parent (Entity (N)))) - = N_Subprogram_Renaming_Declaration + Nkind (Parent (Parent (Entity (N)))) = + N_Subprogram_Renaming_Declaration then Rewrite_Renamed_Operator (N, Alias (Entity (N)), Typ); @@ -2174,7 +2483,7 @@ package body Sem_Res is when N_Allocator => Resolve_Allocator (N, Ctx_Type); - when N_And_Then | N_Or_Else + when N_Short_Circuit => Resolve_Short_Circuit (N, Ctx_Type); when N_Attribute_Reference @@ -2201,15 +2510,15 @@ package body Sem_Res is 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_Membership_Test + => Resolve_Membership_Op (N, Ctx_Type); + when N_Null => Resolve_Null (N, Ctx_Type); when N_Op_And | N_Op_Or | N_Op_Xor @@ -2328,7 +2637,6 @@ package body Sem_Res is if Suppress = All_Checks then declare Svg : constant Suppress_Array := Scope_Suppress; - begin Scope_Suppress := (others => True); Resolve (N, Typ); @@ -2338,7 +2646,6 @@ package body Sem_Res is else declare Svg : constant Boolean := Scope_Suppress (Suppress); - begin Scope_Suppress (Suppress) := True; Resolve (N, Typ); @@ -2369,6 +2676,19 @@ package body Sem_Res is A_Typ : Entity_Id; F_Typ : Entity_Id; Prev : Node_Id := Empty; + Orig_A : Node_Id; + + procedure Check_Argument_Order; + -- Performs a check for the case where the actuals are all simple + -- identifiers that correspond to the formal names, but in the wrong + -- order, which is considered suspicious and cause for a warning. + + procedure Check_Prefixed_Call; + -- If the original node is an overloaded call in prefix notation, + -- insert an 'Access or a dereference as needed over the first actual. + -- Try_Object_Operation has already verified that there is a valid + -- interpretation, but the form of the actual can only be determined + -- once the primitive operation is identified. procedure Insert_Default; -- If the actual is missing in a call, insert in the actuals list @@ -2380,41 +2700,219 @@ package body Sem_Res is -- common type. Used to enforce the restrictions on array conversions -- of AI95-00246. - -------------------- - -- Insert_Default -- - -------------------- + function Static_Concatenation (N : Node_Id) return Boolean; + -- Predicate to determine whether an actual that is a concatenation + -- will be evaluated statically and does not need a transient scope. + -- This must be determined before the actual is resolved and expanded + -- because if needed the transient scope must be introduced earlier. - procedure Insert_Default is - Actval : Node_Id; - Assoc : Node_Id; + -------------------------- + -- Check_Argument_Order -- + -------------------------- + procedure Check_Argument_Order is begin - -- Missing argument in call, nothing to insert - - if No (Default_Value (F)) then + -- Nothing to do if no parameters, or original node is neither a + -- function call nor a procedure call statement (happens in the + -- operator-transformed-to-function call case), or the call does + -- not come from source, or this warning is off. + + if not Warn_On_Parameter_Order + or else + No (Parameter_Associations (N)) + or else + not Nkind_In (Original_Node (N), N_Procedure_Call_Statement, + N_Function_Call) + or else + not Comes_From_Source (N) + then return; + end if; - else - -- Note that we do a full New_Copy_Tree, so that any associated - -- Itypes are properly copied. This may not be needed any more, - -- but it does no harm as a safety measure! Defaults of a generic - -- formal may be out of bounds of the corresponding actual (see - -- cc1311b) and an additional check may be required. + declare + Nargs : constant Nat := List_Length (Parameter_Associations (N)); - Actval := New_Copy_Tree (Default_Value (F), - New_Scope => Current_Scope, New_Sloc => Loc); + begin + -- Nothing to do if only one parameter - if Is_Concurrent_Type (Scope (Nam)) - and then Has_Discriminants (Scope (Nam)) - then - Replace_Actual_Discriminants (N, Actval); + if Nargs < 2 then + return; 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)) + -- Here if at least two arguments + + declare + Actuals : array (1 .. Nargs) of Node_Id; + Actual : Node_Id; + Formal : Node_Id; + + Wrong_Order : Boolean := False; + -- Set True if an out of order case is found + + begin + -- Collect identifier names of actuals, fail if any actual is + -- not a simple identifier, and record max length of name. + + Actual := First (Parameter_Associations (N)); + for J in Actuals'Range loop + if Nkind (Actual) /= N_Identifier then + return; + else + Actuals (J) := Actual; + Next (Actual); + end if; + end loop; + + -- If we got this far, all actuals are identifiers and the list + -- of their names is stored in the Actuals array. + + Formal := First_Formal (Nam); + for J in Actuals'Range loop + + -- If we ran out of formals, that's odd, probably an error + -- which will be detected elsewhere, but abandon the search. + + if No (Formal) then + return; + end if; + + -- If name matches and is in order OK + + if Chars (Formal) = Chars (Actuals (J)) then + null; + + else + -- If no match, see if it is elsewhere in list and if so + -- flag potential wrong order if type is compatible. + + for K in Actuals'Range loop + if Chars (Formal) = Chars (Actuals (K)) + and then + Has_Compatible_Type (Actuals (K), Etype (Formal)) + then + Wrong_Order := True; + goto Continue; + end if; + end loop; + + -- No match + + return; + end if; + + <> Next_Formal (Formal); + end loop; + + -- If Formals left over, also probably an error, skip warning + + if Present (Formal) then + return; + end if; + + -- Here we give the warning if something was out of order + + if Wrong_Order then + Error_Msg_N + ("actuals for this call may be in wrong order?", N); + end if; + end; + end; + end Check_Argument_Order; + + ------------------------- + -- Check_Prefixed_Call -- + ------------------------- + + procedure Check_Prefixed_Call is + Act : constant Node_Id := First_Actual (N); + A_Type : constant Entity_Id := Etype (Act); + F_Type : constant Entity_Id := Etype (First_Formal (Nam)); + Orig : constant Node_Id := Original_Node (N); + New_A : Node_Id; + + begin + -- Check whether the call is a prefixed call, with or without + -- additional actuals. + + if Nkind (Orig) = N_Selected_Component + or else + (Nkind (Orig) = N_Indexed_Component + and then Nkind (Prefix (Orig)) = N_Selected_Component + and then Is_Entity_Name (Prefix (Prefix (Orig))) + and then Is_Entity_Name (Act) + and then Chars (Act) = Chars (Prefix (Prefix (Orig)))) + then + if Is_Access_Type (A_Type) + and then not Is_Access_Type (F_Type) + then + -- Introduce dereference on object in prefix + + New_A := + Make_Explicit_Dereference (Sloc (Act), + Prefix => Relocate_Node (Act)); + Rewrite (Act, New_A); + Analyze (Act); + + elsif Is_Access_Type (F_Type) + and then not Is_Access_Type (A_Type) + then + -- Introduce an implicit 'Access in prefix + + if not Is_Aliased_View (Act) then + Error_Msg_NE + ("object in prefixed call to& must be aliased" + & " (RM-2005 4.3.1 (13))", + Prefix (Act), Nam); + end if; + + Rewrite (Act, + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Access, + Prefix => Relocate_Node (Act))); + end if; + + Analyze (Act); + end if; + end Check_Prefixed_Call; + + -------------------- + -- Insert_Default -- + -------------------- + + procedure Insert_Default is + Actval : Node_Id; + Assoc : Node_Id; + + begin + -- Missing argument in call, nothing to insert + + if No (Default_Value (F)) then + return; + + else + -- Note that we do a full New_Copy_Tree, so that any associated + -- Itypes are properly copied. This may not be needed any more, + -- but it does no harm as a safety measure! Defaults of a generic + -- formal may be out of bounds of the corresponding actual (see + -- cc1311b) and an additional check may be required. + + Actval := + New_Copy_Tree + (Default_Value (F), + New_Scope => Current_Scope, + New_Sloc => Loc); + + if Is_Concurrent_Type (Scope (Nam)) + and then Has_Discriminants (Scope (Nam)) + then + Replace_Actual_Discriminants (N, Actval); + end if; + + if Is_Overloadable (Nam) + and then Present (Alias (Nam)) + then + if Base_Type (Etype (F)) /= Base_Type (Etype (Actval)) + and then not Is_Tagged_Type (Etype (F)) then -- If default is a real literal, do not introduce a -- conversion whose effect may depend on the run-time @@ -2434,13 +2932,11 @@ package body Sem_Res is Set_Parent (Actval, N); -- Resolve aggregates with their base type, to avoid scope - -- anomalies: the subtype was first built in the suprogram + -- anomalies: the subtype was first built in the subprogram -- declaration, and the current call may be nested. - if Nkind (Actval) = N_Aggregate - and then Has_Discriminants (Etype (Actval)) - then - Analyze_And_Resolve (Actval, Base_Type (Etype (Actval))); + if Nkind (Actval) = N_Aggregate then + Analyze_And_Resolve (Actval, Etype (F)); else Analyze_And_Resolve (Actval, Etype (Actval)); end if; @@ -2505,7 +3001,7 @@ package body Sem_Res is Set_First_Named_Actual (N, Actval); if No (Prev) then - if not Present (Parameter_Associations (N)) then + if No (Parameter_Associations (N)) then Set_Parameter_Associations (N, New_List (Assoc)); else Append (Assoc, Parameter_Associations (N)); @@ -2554,18 +3050,62 @@ package body Sem_Res is return Root_Type (Base_Type (FT1)) = Root_Type (Base_Type (FT2)); end Same_Ancestor; + -------------------------- + -- Static_Concatenation -- + -------------------------- + + function Static_Concatenation (N : Node_Id) return Boolean is + begin + case Nkind (N) is + when N_String_Literal => + return True; + + when N_Op_Concat => + + -- Concatenation is static when both operands are static + -- and the concatenation operator is a predefined one. + + return Scope (Entity (N)) = Standard_Standard + and then + Static_Concatenation (Left_Opnd (N)) + and then + Static_Concatenation (Right_Opnd (N)); + + when others => + if Is_Entity_Name (N) then + declare + Ent : constant Entity_Id := Entity (N); + begin + return Ekind (Ent) = E_Constant + and then Present (Constant_Value (Ent)) + and then + Is_Static_Expression (Constant_Value (Ent)); + end; + + else + return False; + end if; + end case; + end Static_Concatenation; + -- Start of processing for Resolve_Actuals begin + Check_Argument_Order; + + if Present (First_Actual (N)) then + Check_Prefixed_Call; + end if; + A := First_Actual (N); F := First_Formal (Nam); while Present (F) loop if No (A) and then Needs_No_Actuals (Nam) then null; - -- If we have an error in any actual or formal, indicated by - -- a type of Any_Type, then abandon resolution attempt, and - -- set result type to Any_Type. + -- If we have an error in any actual or formal, indicated by a type + -- of Any_Type, then abandon resolution attempt, and set result type + -- to Any_Type. elsif (Present (A) and then Etype (A) = Any_Type) or else Etype (F) = Any_Type @@ -2574,20 +3114,56 @@ package body Sem_Res is return; end if; + -- Case where actual is present + + -- If the actual is an entity, generate a reference to it now. We + -- do this before the actual is resolved, because a formal of some + -- protected subprogram, or a task discriminant, will be rewritten + -- during expansion, and the reference to the source entity may + -- be lost. + + if Present (A) + and then Is_Entity_Name (A) + and then Comes_From_Source (N) + then + Orig_A := Entity (A); + + if Present (Orig_A) then + if Is_Formal (Orig_A) + and then Ekind (F) /= E_In_Parameter + then + Generate_Reference (Orig_A, A, 'm'); + elsif not Is_Overloaded (A) then + Generate_Reference (Orig_A, A); + end if; + end if; + end if; + if Present (A) and then (Nkind (Parent (A)) /= N_Parameter_Association or else Chars (Selector_Name (Parent (A))) = Chars (F)) then + -- If style checking mode on, check match of formal name + + if Style_Check then + if Nkind (Parent (A)) = N_Parameter_Association then + Check_Identifier (Selector_Name (Parent (A)), F); + end if; + end if; + -- If the formal is Out or In_Out, do not resolve and expand the -- conversion, because it is subsequently expanded into explicit -- temporaries and assignments. However, the object of the - -- conversion can be resolved. An exception is the case of - -- 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. + -- conversion can be resolved. An exception is the case of tagged + -- type conversion with a class-wide actual. In that case we want + -- the tag check to occur and no temporary will be needed (no + -- representation change can occur) and the parameter is passed by + -- reference, so we go ahead and resolve the type conversion. + -- Another exception is the case of reference to component or + -- subcomponent of a bit-packed array, in which case we want to + -- defer expansion to the point the in and out assignments are + -- performed. if Ekind (F) /= E_In_Parameter and then Nkind (A) = N_Type_Conversion @@ -2599,41 +3175,94 @@ package body Sem_Res is if Has_Aliased_Components (Etype (Expression (A))) /= Has_Aliased_Components (Etype (F)) then - if Ada_Version < Ada_05 then - Error_Msg_N - ("both component types in a view conversion must be" - & " aliased, or neither", A); - -- Ada 2005: rule is relaxed (see AI-363) + -- In a view conversion, the conversion must be legal in + -- both directions, and thus both component types must be + -- aliased, or neither (4.6 (8)). + + -- The additional rule 4.6 (24.9.2) seems unduly + -- restrictive: the privacy requirement should not apply + -- to generic types, and should be checked in an + -- instance. ARG query is in order ??? + + Error_Msg_N + ("both component types in a view conversion must be" + & " aliased, or neither", A); - elsif Has_Aliased_Components (Etype (F)) - and then - not Has_Aliased_Components (Etype (Expression (A))) + elsif + not Same_Ancestor (Etype (F), Etype (Expression (A))) + then + if Is_By_Reference_Type (Etype (F)) + or else Is_By_Reference_Type (Etype (Expression (A))) then Error_Msg_N - ("view conversion operand must have aliased " & - "components", N); - Error_Msg_N - ("\since target type has aliased components", N); + ("view conversion between unrelated by reference " & + "array types not allowed (\'A'I-00246)", A); + else + declare + Comp_Type : constant Entity_Id := + Component_Type + (Etype (Expression (A))); + begin + if Comes_From_Source (A) + and then Ada_Version >= Ada_05 + and then + ((Is_Private_Type (Comp_Type) + and then not Is_Generic_Type (Comp_Type)) + or else Is_Tagged_Type (Comp_Type) + or else Is_Volatile (Comp_Type)) + then + Error_Msg_N + ("component type of a view conversion cannot" + & " be private, tagged, or volatile" + & " (RM 4.6 (24))", + Expression (A)); + end if; + end; end if; - - elsif not Same_Ancestor (Etype (F), Etype (Expression (A))) - and then - (Is_By_Reference_Type (Etype (F)) - or else Is_By_Reference_Type (Etype (Expression (A)))) - then - Error_Msg_N - ("view conversion between unrelated by reference " & - "array types not allowed (\'A'I-00246)", A); end if; end if; - if Conversion_OK (A) - or else Valid_Conversion (A, Etype (A), Expression (A)) + if (Conversion_OK (A) + or else Valid_Conversion (A, Etype (A), Expression (A))) + and then not Is_Ref_To_Bit_Packed_Array (Expression (A)) then Resolve (Expression (A)); end if; + -- If the actual is a function call that returns a limited + -- unconstrained object that needs finalization, create a + -- transient scope for it, so that it can receive the proper + -- finalization list. + + elsif Nkind (A) = N_Function_Call + and then Is_Limited_Record (Etype (F)) + and then not Is_Constrained (Etype (F)) + and then Expander_Active + and then + (Is_Controlled (Etype (F)) or else Has_Task (Etype (F))) + then + Establish_Transient_Scope (A, False); + + -- A small optimization: if one of the actuals is a concatenation + -- create a block around a procedure call to recover stack space. + -- This alleviates stack usage when several procedure calls in + -- the same statement list use concatenation. We do not perform + -- this wrapping for code statements, where the argument is a + -- static string, and we want to preserve warnings involving + -- sequences of such statements. + + elsif Nkind (A) = N_Op_Concat + and then Nkind (N) = N_Procedure_Call_Statement + and then Expander_Active + and then + not (Is_Intrinsic_Subprogram (Nam) + and then Chars (Nam) = Name_Asm) + and then not Static_Concatenation (A) + then + Establish_Transient_Scope (A, False); + Resolve (A, Etype (F)); + else if Nkind (A) = N_Type_Conversion and then Is_Array_Type (Etype (F)) @@ -2655,12 +3284,116 @@ package body Sem_Res is end if; end if; - Resolve (A, Etype (F)); + -- (Ada 2005: AI-251): If the actual is an allocator whose + -- directly designated type is a class-wide interface, we build + -- an anonymous access type to use it as the type of the + -- allocator. Later, when the subprogram call is expanded, if + -- the interface has a secondary dispatch table the expander + -- will add a type conversion to force the correct displacement + -- of the pointer. + + if Nkind (A) = N_Allocator then + declare + DDT : constant Entity_Id := + Directly_Designated_Type (Base_Type (Etype (F))); + + New_Itype : Entity_Id; + + begin + if Is_Class_Wide_Type (DDT) + and then Is_Interface (DDT) + then + New_Itype := Create_Itype (E_Anonymous_Access_Type, A); + Set_Etype (New_Itype, Etype (A)); + Set_Directly_Designated_Type (New_Itype, + Directly_Designated_Type (Etype (A))); + Set_Etype (A, New_Itype); + end if; + + -- Ada 2005, AI-162:If the actual is an allocator, the + -- innermost enclosing statement is the master of the + -- created object. This needs to be done with expansion + -- enabled only, otherwise the transient scope will not + -- be removed in the expansion of the wrapped construct. + + if (Is_Controlled (DDT) or else Has_Task (DDT)) + and then Expander_Active + then + Establish_Transient_Scope (A, False); + end if; + end; + end if; + + -- (Ada 2005): The call may be to a primitive operation of + -- a tagged synchronized type, declared outside of the type. + -- In this case the controlling actual must be converted to + -- its corresponding record type, which is the formal type. + -- The actual may be a subtype, either because of a constraint + -- or because it is a generic actual, so use base type to + -- locate concurrent type. + + A_Typ := Base_Type (Etype (A)); + F_Typ := Base_Type (Etype (F)); + + declare + Full_A_Typ : Entity_Id; + + begin + if Present (Full_View (A_Typ)) then + Full_A_Typ := Base_Type (Full_View (A_Typ)); + else + Full_A_Typ := A_Typ; + end if; + + -- Tagged synchronized type (case 1): the actual is a + -- concurrent type + + if Is_Concurrent_Type (A_Typ) + and then Corresponding_Record_Type (A_Typ) = F_Typ + then + Rewrite (A, + Unchecked_Convert_To + (Corresponding_Record_Type (A_Typ), A)); + Resolve (A, Etype (F)); + + -- Tagged synchronized type (case 2): the formal is a + -- concurrent type + + elsif Ekind (Full_A_Typ) = E_Record_Type + and then Present + (Corresponding_Concurrent_Type (Full_A_Typ)) + and then Is_Concurrent_Type (F_Typ) + and then Present (Corresponding_Record_Type (F_Typ)) + and then Full_A_Typ = Corresponding_Record_Type (F_Typ) + then + Resolve (A, Corresponding_Record_Type (F_Typ)); + + -- Common case + + else + Resolve (A, Etype (F)); + end if; + end; end if; A_Typ := Etype (A); F_Typ := Etype (F); + -- For mode IN, if actual is an entity, and the type of the formal + -- has warnings suppressed, then we reset Never_Set_In_Source for + -- the calling entity. The reason for this is to catch cases like + -- GNAT.Spitbol.Patterns.Vstring_Var where the called subprogram + -- uses trickery to modify an IN parameter. + + if Ekind (F) = E_In_Parameter + and then Is_Entity_Name (A) + and then Present (Entity (A)) + and then Ekind (Entity (A)) = E_Variable + and then Has_Warnings_Off (F_Typ) + then + Set_Never_Set_In_Source (Entity (A), False); + end if; + -- Perform error checks for IN and IN OUT parameters if Ekind (F) /= E_Out_Parameter then @@ -2700,10 +3433,39 @@ package body Sem_Res is end if; end if; - if Ekind (F) /= E_In_Parameter - and then not Is_OK_Variable_For_Out_Formal (A) - then - Error_Msg_NE ("actual for& must be a variable", A, F); + -- Case of OUT or IN OUT parameter + + if Ekind (F) /= E_In_Parameter then + + -- For an Out parameter, check for useless assignment. Note + -- that we can't set Last_Assignment this early, because we may + -- kill current values in Resolve_Call, and that call would + -- clobber the Last_Assignment field. + + -- Note: call Warn_On_Useless_Assignment before doing the check + -- below for Is_OK_Variable_For_Out_Formal so that the setting + -- of Referenced_As_LHS/Referenced_As_Out_Formal properly + -- reflects the last assignment, not this one! + + if Ekind (F) = E_Out_Parameter then + if Warn_On_Modified_As_Out_Parameter (F) + and then Is_Entity_Name (A) + and then Present (Entity (A)) + and then Comes_From_Source (N) + then + Warn_On_Useless_Assignment (Entity (A), A); + end if; + end if; + + -- Validate the form of the actual. Note that the call to + -- Is_OK_Variable_For_Out_Formal generates the required + -- reference in this case. + + if not Is_OK_Variable_For_Out_Formal (A) then + Error_Msg_NE ("actual for& must be a variable", A, F); + end if; + + -- What's the following about??? if Is_Entity_Name (A) then Kill_Checks (Entity (A)); @@ -2765,16 +3527,14 @@ package body Sem_Res is if Ada_Version >= Ada_05 and then Is_Access_Type (F_Typ) - and then (Can_Never_Be_Null (F) - or else Can_Never_Be_Null (F_Typ)) + and then Can_Never_Be_Null (F_Typ) + and then Known_Null (A) then - if Nkind (A) = N_Null then - Apply_Compile_Time_Constraint_Error - (N => A, - Msg => "(Ada 2005) NULL not allowed in " - & "null-excluding formal?", - Reason => CE_Null_Not_Allowed); - end if; + Apply_Compile_Time_Constraint_Error + (N => A, + Msg => "(Ada 2005) null not allowed in " + & "null-excluding formal?", + Reason => CE_Null_Not_Allowed); end if; end if; @@ -2806,8 +3566,8 @@ package body Sem_Res is 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. + -- 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 @@ -2838,10 +3598,30 @@ package body Sem_Res is end if; -- Check that subprograms don't have improper controlling - -- arguments (RM 3.9.2 (9)) + -- arguments (RM 3.9.2 (9)). + + -- A primitive operation may have an access parameter of an + -- incomplete tagged type, but a dispatching call is illegal + -- if the type is still incomplete. if Is_Controlling_Formal (F) then Set_Is_Controlling_Actual (A); + + if Ekind (Etype (F)) = E_Anonymous_Access_Type then + declare + Desig : constant Entity_Id := Designated_Type (Etype (F)); + begin + if Ekind (Desig) = E_Incomplete_Type + and then No (Full_View (Desig)) + and then No (Non_Limited_View (Desig)) + then + Error_Msg_NE + ("premature use of incomplete type& " & + "in dispatching call", A, Desig); + end if; + end; + end if; + elsif Nkind (A) = N_Explicit_Dereference then Validate_Remote_Access_To_Class_Wide_Type (A); end if; @@ -2863,12 +3643,20 @@ package body Sem_Res is elsif Is_Access_Type (A_Typ) and then Is_Access_Type (F_Typ) and then Ekind (F_Typ) /= E_Access_Subprogram_Type + and then Ekind (F_Typ) /= E_Anonymous_Access_Subprogram_Type and then (Is_Class_Wide_Type (Designated_Type (A_Typ)) or else (Nkind (A) = N_Attribute_Reference and then - Is_Class_Wide_Type (Etype (Prefix (A))))) + 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) + + -- Disable these checks for call to imported C++ subprograms + + and then not + (Is_Entity_Name (Name (N)) + and then Is_Imported (Entity (Name (N))) + and then Convention (Entity (Name (N))) = Convention_CPP) then Error_Msg_N ("access to class-wide argument not allowed here!", A); @@ -2921,12 +3709,104 @@ package body Sem_Res is Subtyp : Entity_Id; Discrim : Entity_Id; Constr : Node_Id; + Aggr : Node_Id; + Assoc : Node_Id := Empty; Disc_Exp : Node_Id; + procedure Check_Allocator_Discrim_Accessibility + (Disc_Exp : Node_Id; + Alloc_Typ : Entity_Id); + -- Check that accessibility level associated with an access discriminant + -- initialized in an allocator by the expression Disc_Exp is not deeper + -- than the level of the allocator type Alloc_Typ. An error message is + -- issued if this condition is violated. Specialized checks are done for + -- the cases of a constraint expression which is an access attribute or + -- an access discriminant. + function In_Dispatching_Context return Boolean; - -- If the allocator is an actual in a call, it is allowed to be - -- class-wide when the context is not because it is a controlling - -- actual. + -- If the allocator is an actual in a call, it is allowed to be class- + -- wide when the context is not because it is a controlling actual. + + procedure Propagate_Coextensions (Root : Node_Id); + -- Propagate all nested coextensions which are located one nesting + -- level down the tree to the node Root. Example: + -- + -- Top_Record + -- Level_1_Coextension + -- Level_2_Coextension + -- + -- The algorithm is paired with delay actions done by the Expander. In + -- the above example, assume all coextensions are controlled types. + -- The cycle of analysis, resolution and expansion will yield: + -- + -- 1) Analyze Top_Record + -- 2) Analyze Level_1_Coextension + -- 3) Analyze Level_2_Coextension + -- 4) Resolve Level_2_Coextension. The allocator is marked as a + -- coextension. + -- 5) Expand Level_2_Coextension. A temporary variable Temp_1 is + -- generated to capture the allocated object. Temp_1 is attached + -- to the coextension chain of Level_2_Coextension. + -- 6) Resolve Level_1_Coextension. The allocator is marked as a + -- coextension. A forward tree traversal is performed which finds + -- Level_2_Coextension's list and copies its contents into its + -- own list. + -- 7) Expand Level_1_Coextension. A temporary variable Temp_2 is + -- generated to capture the allocated object. Temp_2 is attached + -- to the coextension chain of Level_1_Coextension. Currently, the + -- contents of the list are [Temp_2, Temp_1]. + -- 8) Resolve Top_Record. A forward tree traversal is performed which + -- finds Level_1_Coextension's list and copies its contents into + -- its own list. + -- 9) Expand Top_Record. Generate finalization calls for Temp_1 and + -- Temp_2 and attach them to Top_Record's finalization list. + + ------------------------------------------- + -- Check_Allocator_Discrim_Accessibility -- + ------------------------------------------- + + procedure Check_Allocator_Discrim_Accessibility + (Disc_Exp : Node_Id; + Alloc_Typ : Entity_Id) + is + begin + if Type_Access_Level (Etype (Disc_Exp)) > + Type_Access_Level (Alloc_Typ) + then + Error_Msg_N + ("operand type has deeper level than allocator type", Disc_Exp); + + -- When the expression is an Access attribute the level of the prefix + -- object must not be deeper than that of the allocator's type. + + elsif Nkind (Disc_Exp) = N_Attribute_Reference + and then Get_Attribute_Id (Attribute_Name (Disc_Exp)) + = Attribute_Access + and then Object_Access_Level (Prefix (Disc_Exp)) + > Type_Access_Level (Alloc_Typ) + then + Error_Msg_N + ("prefix of attribute has deeper level than allocator type", + Disc_Exp); + + -- When the expression is an access discriminant the check is against + -- the level of the prefix object. + + elsif Ekind (Etype (Disc_Exp)) = E_Anonymous_Access_Type + and then Nkind (Disc_Exp) = N_Selected_Component + and then Object_Access_Level (Prefix (Disc_Exp)) + > Type_Access_Level (Alloc_Typ) + then + Error_Msg_N + ("access discriminant has deeper level than allocator type", + Disc_Exp); + + -- All other cases are legal + + else + null; + end if; + end Check_Allocator_Discrim_Accessibility; ---------------------------- -- In_Dispatching_Context -- @@ -2934,14 +3814,141 @@ package body Sem_Res is function In_Dispatching_Context return Boolean is Par : constant Node_Id := Parent (N); - begin - return (Nkind (Par) = N_Function_Call - or else Nkind (Par) = N_Procedure_Call_Statement) + return Nkind_In (Par, N_Function_Call, N_Procedure_Call_Statement) and then Is_Entity_Name (Name (Par)) and then Is_Dispatching_Operation (Entity (Name (Par))); end In_Dispatching_Context; + ---------------------------- + -- Propagate_Coextensions -- + ---------------------------- + + procedure Propagate_Coextensions (Root : Node_Id) is + + procedure Copy_List (From : Elist_Id; To : Elist_Id); + -- Copy the contents of list From into list To, preserving the + -- order of elements. + + function Process_Allocator (Nod : Node_Id) return Traverse_Result; + -- Recognize an allocator or a rewritten allocator node and add it + -- along with its nested coextensions to the list of Root. + + --------------- + -- Copy_List -- + --------------- + + procedure Copy_List (From : Elist_Id; To : Elist_Id) is + From_Elmt : Elmt_Id; + begin + From_Elmt := First_Elmt (From); + while Present (From_Elmt) loop + Append_Elmt (Node (From_Elmt), To); + Next_Elmt (From_Elmt); + end loop; + end Copy_List; + + ----------------------- + -- Process_Allocator -- + ----------------------- + + function Process_Allocator (Nod : Node_Id) return Traverse_Result is + Orig_Nod : Node_Id := Nod; + + begin + -- This is a possible rewritten subtype indication allocator. Any + -- nested coextensions will appear as discriminant constraints. + + if Nkind (Nod) = N_Identifier + and then Present (Original_Node (Nod)) + and then Nkind (Original_Node (Nod)) = N_Subtype_Indication + then + declare + Discr : Node_Id; + Discr_Elmt : Elmt_Id; + + begin + if Is_Record_Type (Entity (Nod)) then + Discr_Elmt := + First_Elmt (Discriminant_Constraint (Entity (Nod))); + while Present (Discr_Elmt) loop + Discr := Node (Discr_Elmt); + + if Nkind (Discr) = N_Identifier + and then Present (Original_Node (Discr)) + and then Nkind (Original_Node (Discr)) = N_Allocator + and then Present (Coextensions ( + Original_Node (Discr))) + then + if No (Coextensions (Root)) then + Set_Coextensions (Root, New_Elmt_List); + end if; + + Copy_List + (From => Coextensions (Original_Node (Discr)), + To => Coextensions (Root)); + end if; + + Next_Elmt (Discr_Elmt); + end loop; + + -- There is no need to continue the traversal of this + -- subtree since all the information has already been + -- propagated. + + return Skip; + end if; + end; + + -- Case of either a stand alone allocator or a rewritten allocator + -- with an aggregate. + + else + if Present (Original_Node (Nod)) then + Orig_Nod := Original_Node (Nod); + end if; + + if Nkind (Orig_Nod) = N_Allocator then + + -- Propagate the list of nested coextensions to the Root + -- allocator. This is done through list copy since a single + -- allocator may have multiple coextensions. Do not touch + -- coextensions roots. + + if not Is_Coextension_Root (Orig_Nod) + and then Present (Coextensions (Orig_Nod)) + then + if No (Coextensions (Root)) then + Set_Coextensions (Root, New_Elmt_List); + end if; + + Copy_List + (From => Coextensions (Orig_Nod), + To => Coextensions (Root)); + end if; + + -- There is no need to continue the traversal of this + -- subtree since all the information has already been + -- propagated. + + return Skip; + end if; + end if; + + -- Keep on traversing, looking for the next allocator + + return OK; + end Process_Allocator; + + procedure Process_Allocators is + new Traverse_Proc (Process_Allocator); + + -- Start of processing for Propagate_Coextensions + + begin + Process_Allocators (Expression (Root)); + end Propagate_Coextensions; + -- Start of processing for Resolve_Allocator begin @@ -2951,7 +3958,7 @@ package body Sem_Res is Set_Etype (N, Base_Type (Typ)); end if; - if Is_Abstract (Typ) then + if Is_Abstract_Type (Typ) then Error_Msg_N ("type of allocator cannot be abstract", N); end if; @@ -2974,12 +3981,81 @@ package body Sem_Res is -- class-wide matching is not allowed. if (Is_Class_Wide_Type (Etype (Expression (E))) - or else Is_Class_Wide_Type (Etype (E))) + or else Is_Class_Wide_Type (Etype (E))) and then Base_Type (Etype (Expression (E))) /= Base_Type (Etype (E)) then Wrong_Type (Expression (E), Etype (E)); end if; + -- A special accessibility check is needed for allocators that + -- constrain access discriminants. The level of the type of the + -- expression used to constrain an access discriminant cannot be + -- deeper than the type of the allocator (in contrast to access + -- parameters, where the level of the actual can be arbitrary). + + -- We can't use Valid_Conversion to perform this check because + -- in general the type of the allocator is unrelated to the type + -- of the access discriminant. + + if Ekind (Typ) /= E_Anonymous_Access_Type + or else Is_Local_Anonymous_Access (Typ) + then + Subtyp := Entity (Subtype_Mark (E)); + + Aggr := Original_Node (Expression (E)); + + if Has_Discriminants (Subtyp) + and then Nkind_In (Aggr, N_Aggregate, N_Extension_Aggregate) + then + Discrim := First_Discriminant (Base_Type (Subtyp)); + + -- Get the first component expression of the aggregate + + if Present (Expressions (Aggr)) then + Disc_Exp := First (Expressions (Aggr)); + + elsif Present (Component_Associations (Aggr)) then + Assoc := First (Component_Associations (Aggr)); + + if Present (Assoc) then + Disc_Exp := Expression (Assoc); + else + Disc_Exp := Empty; + end if; + + else + Disc_Exp := Empty; + end if; + + while Present (Discrim) and then Present (Disc_Exp) loop + if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then + Check_Allocator_Discrim_Accessibility (Disc_Exp, Typ); + end if; + + Next_Discriminant (Discrim); + + if Present (Discrim) then + if Present (Assoc) then + Next (Assoc); + Disc_Exp := Expression (Assoc); + + elsif Present (Next (Disc_Exp)) then + Next (Disc_Exp); + + else + Assoc := First (Component_Associations (Aggr)); + + if Present (Assoc) then + Disc_Exp := Expression (Assoc); + else + Disc_Exp := Empty; + end if; + end if; + end if; + end loop; + end if; + end if; + -- For a subtype mark or subtype indication, freeze the subtype else @@ -2992,24 +4068,22 @@ package body Sem_Res is -- 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 + -- expression used to constrain an access discriminant cannot be + -- deeper than the type of the allocator (in contrast to access -- parameters, where the level of the actual can be arbitrary). -- We can't use Valid_Conversion to perform this check because -- in general the type of the allocator is unrelated to the type - -- of the access discriminant. Note that specialized checks are - -- needed for the cases of a constraint expression which is an - -- access attribute or an access discriminant. + -- of the access discriminant. if Nkind (Original_Node (E)) = N_Subtype_Indication - and then Ekind (Typ) /= E_Anonymous_Access_Type + and then (Ekind (Typ) /= E_Anonymous_Access_Type + or else Is_Local_Anonymous_Access (Typ)) then Subtyp := Entity (Subtype_Mark (Original_Node (E))); if Has_Discriminants (Subtyp) then Discrim := First_Discriminant (Base_Type (Subtyp)); Constr := First (Constraints (Constraint (Original_Node (E)))); - while Present (Discrim) and then Present (Constr) loop if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then if Nkind (Constr) = N_Discriminant_Association then @@ -3018,36 +4092,9 @@ package body Sem_Res is 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; + Check_Allocator_Discrim_Accessibility (Disc_Exp, Typ); end if; + Next_Discriminant (Discrim); Next (Constr); end loop; @@ -3067,7 +4114,7 @@ package body Sem_Res is and then Is_Class_Wide_Type (Designated_Type (Typ)) then declare - Exp_Typ : Entity_Id; + Exp_Typ : Entity_Id; begin if Nkind (E) = N_Qualified_Expression then @@ -3082,12 +4129,18 @@ package body Sem_Res is if In_Instance_Body then Error_Msg_N ("?type in allocator has deeper level than" & " designated class-wide type", E); - Error_Msg_N ("?Program_Error will be raised at run time", E); + Error_Msg_N ("\?Program_Error will be raised at run time", + E); Rewrite (N, Make_Raise_Program_Error (Sloc (N), Reason => PE_Accessibility_Check_Failed)); Set_Etype (N, Typ); - else + + -- Do not apply Ada 2005 accessibility checks on a class-wide + -- allocator if the type given in the allocator is a formal + -- type. A run-time check will be performed in the instance. + + elsif not Is_Generic_Type (Exp_Typ) then Error_Msg_N ("type in allocator has deeper level than" & " designated class-wide type", E); end if; @@ -3100,14 +4153,58 @@ package body Sem_Res is 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); + Error_Msg_N ("\?Storage_Error will be raised at run time!", N); Insert_Action (N, Make_Raise_Storage_Error (Loc, Reason => SE_Empty_Storage_Pool)); end; + + -- If the context is an unchecked conversion, as may happen within + -- an inlined subprogram, the allocator is being resolved with its + -- own anonymous type. In that case, if the target type has a specific + -- storage pool, it must be inherited explicitly by the allocator type. + + elsif Nkind (Parent (N)) = N_Unchecked_Type_Conversion + and then No (Associated_Storage_Pool (Typ)) + then + Set_Associated_Storage_Pool + (Typ, Associated_Storage_Pool (Etype (Parent (N)))); + end if; + + -- An erroneous allocator may be rewritten as a raise Program_Error + -- statement. + + if Nkind (N) = N_Allocator then + + -- An anonymous access discriminant is the definition of a + -- coextension. + + if Ekind (Typ) = E_Anonymous_Access_Type + and then Nkind (Associated_Node_For_Itype (Typ)) = + N_Discriminant_Specification + then + -- Avoid marking an allocator as a dynamic coextension if it is + -- within a static construct. + + if not Is_Static_Coextension (N) then + Set_Is_Dynamic_Coextension (N); + end if; + + -- Cleanup for potential static coextensions + + else + Set_Is_Dynamic_Coextension (N, False); + Set_Is_Static_Coextension (N, False); + end if; + + -- There is no need to propagate any nested coextensions if they + -- are marked as static since they will be rewritten on the spot. + + if not Is_Static_Coextension (N) then + Propagate_Coextensions (N); + end if; end if; end Resolve_Allocator; @@ -3129,6 +4226,9 @@ package body Sem_Res is -- We do the resolution using the base type, because intermediate values -- in expressions always are of the base type, not a subtype of it. + function Expected_Type_Is_Any_Real (N : Node_Id) return Boolean; + -- Returns True if N is in a context that expects "any real type" + function Is_Integer_Or_Universal (N : Node_Id) return Boolean; -- Return True iff given type is Integer or universal real/integer @@ -3140,6 +4240,29 @@ package body Sem_Res is procedure Set_Operand_Type (N : Node_Id); -- Set operand type to T if universal + ------------------------------- + -- Expected_Type_Is_Any_Real -- + ------------------------------- + + function Expected_Type_Is_Any_Real (N : Node_Id) return Boolean is + begin + -- N is the expression after "delta" in a fixed_point_definition; + -- see RM-3.5.9(6): + + return Nkind_In (Parent (N), N_Ordinary_Fixed_Point_Definition, + N_Decimal_Fixed_Point_Definition, + + -- N is one of the bounds in a real_range_specification; + -- see RM-3.5.7(5): + + N_Real_Range_Specification, + + -- N is the expression of a delta_constraint; + -- see RM-J.3(3): + + N_Delta_Constraint); + end Expected_Type_Is_Any_Real; + ----------------------------- -- Is_Integer_Or_Universal -- ----------------------------- @@ -3157,9 +4280,7 @@ package body Sem_Res is 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 @@ -3247,7 +4368,6 @@ package body Sem_Res is -- 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 @@ -3334,8 +4454,7 @@ package body Sem_Res is -- 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) + elsif (B_Typ = Universal_Integer or else B_Typ = Universal_Real) and then Present (Universal_Interpretation (L)) and then Present (Universal_Interpretation (R)) then @@ -3344,15 +4463,14 @@ package body Sem_Res is 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) + or else Etype (N) = Universal_Fixed + or else (Etype (N) = Any_Fixed + and then Is_Fixed_Point_Type (B_Typ)) + or else (Is_Fixed_Point_Type (B_Typ) + and then (Is_Integer_Or_Universal (L) + or else + Is_Integer_Or_Universal (R)))) + and then Nkind_In (N, N_Op_Multiply, N_Op_Divide) then if TL = Universal_Integer or else TR = Universal_Integer then Check_For_Visible_Operator (N, B_Typ); @@ -3380,42 +4498,55 @@ package body Sem_Res is Set_Mixed_Mode_Operand (R, TL); end if; + -- Check the rule in RM05-4.5.5(19.1/2) disallowing universal_fixed + -- multiplying operators from being used when the expected type is + -- also universal_fixed. Note that B_Typ will be Universal_Fixed in + -- some cases where the expected type is actually Any_Real; + -- Expected_Type_Is_Any_Real takes care of that case. + if Etype (N) = Universal_Fixed or else Etype (N) = Any_Fixed then if B_Typ = Universal_Fixed - and then Nkind (Parent (N)) /= N_Type_Conversion - and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion + and then not Expected_Type_Is_Any_Real (N) + and then not Nkind_In (Parent (N), N_Type_Conversion, + N_Unchecked_Type_Conversion) then - Error_Msg_N - ("type cannot be determined from context!", N); - Error_Msg_N - ("\explicit conversion to result type required", N); + Error_Msg_N ("type cannot be determined from context!", N); + Error_Msg_N ("\explicit conversion to result type required", N); Set_Etype (L, Any_Type); Set_Etype (R, Any_Type); else if Ada_Version = Ada_83 - and then Etype (N) = Universal_Fixed - and then Nkind (Parent (N)) /= N_Type_Conversion - and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion + and then Etype (N) = Universal_Fixed + and then not + Nkind_In (Parent (N), N_Type_Conversion, + N_Unchecked_Type_Conversion) then Error_Msg_N - ("(Ada 83) fixed-point operation " & - "needs explicit conversion", - N); + ("(Ada 83) fixed-point operation " + & "needs explicit conversion", N); end if; - Set_Etype (N, B_Typ); + -- The expected type is "any real type" in contexts like + -- type T is delta ... + -- in which case we need to set the type to Universal_Real + -- so that static expression evaluation will work properly. + + if Expected_Type_Is_Any_Real (N) then + Set_Etype (N, Universal_Real); + else + Set_Etype (N, B_Typ); + end if; end if; elsif Is_Fixed_Point_Type (B_Typ) and then (Is_Integer_Or_Universal (L) or else Nkind (L) = N_Real_Literal or else Nkind (R) = N_Real_Literal - or else - Is_Integer_Or_Universal (R)) + or else Is_Integer_Or_Universal (R)) then Set_Etype (N, B_Typ); @@ -3429,7 +4560,8 @@ package body Sem_Res is else if (TL = Universal_Integer or else TL = Universal_Real) - and then (TR = Universal_Integer or else TR = Universal_Real) + and then + (TR = Universal_Integer or else TR = Universal_Real) then Check_For_Visible_Operator (N, B_Typ); end if; @@ -3438,9 +4570,7 @@ package body Sem_Res is -- 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 + if B_Typ = Universal_Fixed and then Etype (L) = Universal_Fixed then T := Unique_Fixed_Point_Type (N); if T = Any_Type then @@ -3481,30 +4611,94 @@ package body Sem_Res is -- Give warning if explicit division by zero - if (Nkind (N) = N_Op_Divide - or else Nkind (N) = N_Op_Rem - or else Nkind (N) = N_Op_Mod) + if Nkind_In (N, N_Op_Divide, N_Op_Rem, N_Op_Mod) and then not Division_Checks_Suppressed (Etype (N)) then Rop := Right_Opnd (N); if Compile_Time_Known_Value (Rop) and then ((Is_Integer_Type (Etype (Rop)) - and then Expr_Value (Rop) = Uint_0) + and then Expr_Value (Rop) = Uint_0) or else (Is_Real_Type (Etype (Rop)) - and then Expr_Value_R (Rop) = Ureal_0)) + and then Expr_Value_R (Rop) = Ureal_0)) then - Apply_Compile_Time_Constraint_Error - (N, "division by zero?", CE_Divide_By_Zero, - Loc => Sloc (Right_Opnd (N))); + -- Specialize the warning message according to the operation + + case Nkind (N) is + when N_Op_Divide => + Apply_Compile_Time_Constraint_Error + (N, "division by zero?", CE_Divide_By_Zero, + Loc => Sloc (Right_Opnd (N))); + + when N_Op_Rem => + Apply_Compile_Time_Constraint_Error + (N, "rem with zero divisor?", CE_Divide_By_Zero, + Loc => Sloc (Right_Opnd (N))); + + when N_Op_Mod => + Apply_Compile_Time_Constraint_Error + (N, "mod with zero divisor?", CE_Divide_By_Zero, + Loc => Sloc (Right_Opnd (N))); + + -- Division by zero can only happen with division, rem, + -- and mod operations. + + when others => + raise Program_Error; + end case; -- Otherwise just set the flag to check at run time else - Set_Do_Division_Check (N); + Activate_Division_Check (N); end if; end if; + + -- If Restriction No_Implicit_Conditionals is active, then it is + -- violated if either operand can be negative for mod, or for rem + -- if both operands can be negative. + + if Restrictions.Set (No_Implicit_Conditionals) + and then Nkind_In (N, N_Op_Rem, N_Op_Mod) + then + declare + Lo : Uint; + Hi : Uint; + OK : Boolean; + + LNeg : Boolean; + RNeg : Boolean; + -- Set if corresponding operand might be negative + + begin + Determine_Range + (Left_Opnd (N), OK, Lo, Hi, Assume_Valid => True); + LNeg := (not OK) or else Lo < 0; + + Determine_Range + (Right_Opnd (N), OK, Lo, Hi, Assume_Valid => True); + RNeg := (not OK) or else Lo < 0; + + -- Check if we will be generating conditionals. There are two + -- cases where that can happen, first for REM, the only case + -- is largest negative integer mod -1, where the division can + -- overflow, but we still have to give the right result. The + -- front end generates a test for this annoying case. Here we + -- just test if both operands can be negative (that's what the + -- expander does, so we match its logic here). + + -- The second case is mod where either operand can be negative. + -- In this case, the back end has to generate additonal tests. + + if (Nkind (N) = N_Op_Rem and then (LNeg and RNeg)) + or else + (Nkind (N) = N_Op_Mod and then (LNeg or RNeg)) + then + Check_Restriction (No_Implicit_Conditionals, N); + end if; + end; + end if; end if; Check_Unset_Reference (L); @@ -3523,7 +4717,7 @@ package body Sem_Res is It : Interp; Norm_OK : Boolean; Scop : Entity_Id; - W : Node_Id; + Rtype : Entity_Id; begin -- The context imposes a unique interpretation with type Typ on a @@ -3544,9 +4738,9 @@ package body Sem_Res is -- 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; + Get_First_Interp (Subp, I, It); while Present (It.Typ) loop if Covers (Typ, Etype (It.Typ)) then Nam := It.Typ; @@ -3570,18 +4764,17 @@ package body Sem_Res is -- For an indirect call, we always invalidate checks, since we do not -- know whether the subprogram is local or global. Yes we could do -- better here, e.g. by knowing that there are no local subprograms, - -- but it does not seem worth the effort. Similarly, we kill al + -- but it does not seem worth the effort. Similarly, we kill all -- knowledge of current constant values. Kill_Current_Values; - -- If this is a procedure call which is really an entry call, do the - -- conversion of the procedure call to an entry call. Protected - -- operations use the same circuitry because the name in the call can be - -- an arbitrary expression with special resolution rules. + -- 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 + elsif Nkind_In (Subp, N_Selected_Component, N_Indexed_Component) or else (Is_Entity_Name (Subp) and then Ekind (Entity (Subp)) = E_Entry) then @@ -3599,21 +4792,22 @@ package body Sem_Res is 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); + -- Initialize Nam to prevent warning (we know it will be assigned + -- in the loop below, but the compiler does not know that). + Nam := Empty; + + 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; @@ -3621,6 +4815,26 @@ package body Sem_Res is end loop; end if; + if Is_Access_Subprogram_Type (Base_Type (Etype (Nam))) + and then not Is_Access_Subprogram_Type (Base_Type (Typ)) + and then Nkind (Subp) /= N_Explicit_Dereference + and then Present (Parameter_Associations (N)) + then + -- The prefix is a parameterless function call that returns an access + -- to subprogram. If parameters are present in the current call, add + -- add an explicit dereference. We use the base type here because + -- within an instance these may be subtypes. + + -- The dereference is added either in Analyze_Call or here. Should + -- be consolidated ??? + + Set_Is_Overloaded (Subp, False); + Set_Etype (Subp, Etype (Nam)); + Insert_Explicit_Dereference (Subp); + Nam := Designated_Type (Etype (Nam)); + Resolve (Subp, Nam); + end if; + -- Check that a call to Current_Task does not occur in an entry body if Is_RTE (Nam, RE_Current_Task) then @@ -3631,71 +4845,31 @@ package body Sem_Res is 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; + -- Exclude calls that occur within the default of a formal + -- parameter of the entry, since those are evaluated outside + -- of the body. - -- Cannot call thread body directly + exit when No (P) or else Nkind (P) = N_Parameter_Specification; - if Is_Thread_Body (Nam) then - Error_Msg_N ("cannot call thread body directly", N); - end if; - - -- If the subprogram is not global, then kill all checks. This is a bit - -- conservative, since in many cases we could do better, but it is not - -- worth the effort. Similarly, we kill constant values. However we do - -- not need to do this for internal entities (unless they are inherited - -- user-defined subprograms), since they are not in the business of - -- molesting global values. - - if not Is_Library_Level_Entity (Nam) - and then (Comes_From_Source (Nam) - or else (Present (Alias (Nam)) - and then Comes_From_Source (Alias (Nam)))) - then - Kill_Current_Values; - end if; - - -- Deal with call to obsolescent subprogram. Note that we always allow - -- such calls in the compiler itself and the run-time, since we assume - -- that we know what we are doing in such cases. For example, the calls - -- in Ada.Characters.Handling to its own obsolescent subprograms are - -- just fine. - - if Is_Obsolescent (Nam) and then not GNAT_Mode then - Check_Restriction (No_Obsolescent_Features, N); - - if Warn_On_Obsolescent_Feature then - Error_Msg_NE ("call to obsolescent subprogram&?", N, Nam); - - -- Output additional warning if present - - W := Obsolescent_Warning (Nam); - - if Present (W) then - Name_Buffer (1) := '|'; - Name_Buffer (2) := '?'; - Name_Len := 2; - - -- Add characters to message, and output message - - for J in 1 .. String_Length (Strval (W)) loop - Add_Char_To_Name_Buffer ('''); - Add_Char_To_Name_Buffer - (Get_Character (Get_String_Char (Strval (W), J))); - end loop; - - Error_Msg_N (Name_Buffer (1 .. Name_Len), N); - end if; - end if; + if Nkind (P) = N_Entry_Body + or else (Nkind (P) = N_Subprogram_Body + and then Is_Entry_Barrier_Function (P)) + then + Rtype := Etype (N); + Error_Msg_NE + ("?& should not be used in entry body (RM C.7(17))", + N, Nam); + Error_Msg_NE + ("\Program_Error will be raised at run time?", N, Nam); + Rewrite (N, + Make_Raise_Program_Error (Loc, + Reason => PE_Current_Task_In_Entry_Body)); + Set_Etype (N, Rtype); + return; + end if; + end loop; + end; end if; -- Check that a procedure call does not occur in the context of the @@ -3710,11 +4884,27 @@ package body Sem_Res is 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); + if Ada_Version < Ada_05 then + Error_Msg_N ("entry call required in select statement", N); + + -- Ada 2005 (AI-345): If a procedure_call_statement is used + -- for a procedure_or_entry_call, the procedure_name or + -- procedure_prefix of the procedure_call_statement shall denote + -- an entry renamed by a procedure, or (a view of) a primitive + -- subprogram of a limited interface whose first parameter is + -- a controlling parameter. + + elsif Nkind (N) = N_Procedure_Call_Statement + and then not Is_Renamed_Entry (Nam) + and then not Is_Controlling_Limited_Procedure (Nam) + then + Error_Msg_N + ("entry call or dispatching primitive of interface required", N); + end if; end if; - -- Check that this is not a call to a protected procedure or - -- entry from within a protected function. + -- Check that this is not a call to a protected procedure or entry from + -- within a protected function. if Ekind (Current_Scope) = E_Function and then Ekind (Scope (Current_Scope)) = E_Protected_Type @@ -3726,7 +4916,7 @@ package body Sem_Res is Error_Msg_N ("\cannot call operation that may modify it", N); end if; - -- Freeze the subprogram name if not in default expression. Note that we + -- Freeze the subprogram name if not in a spec-expression. Note that we -- freeze procedure calls as well as function calls. Procedure calls are -- not frozen according to the rules (RM 13.14(14)) because it is -- impossible to have a procedure call to a non-frozen procedure in pure @@ -3734,7 +4924,7 @@ package body Sem_Res is -- needs extending because we can generate procedure calls that need -- freezing. - if Is_Entity_Name (Subp) and then not In_Default_Expression then + if Is_Entity_Name (Subp) and then not In_Spec_Expression then Freeze_Expression (Subp); end if; @@ -3754,7 +4944,7 @@ package body Sem_Res is -- when the type of the component is an access to the array type. In -- this case the call is truly ambiguous. - elsif Needs_No_Actuals (Nam) + elsif (Needs_No_Actuals (Nam) or else Needs_One_Actual (Nam)) and then ((Is_Array_Type (Etype (Nam)) and then Covers (Typ, Component_Type (Etype (Nam)))) @@ -3779,13 +4969,40 @@ package body Sem_Res is New_Subp := Relocate_Node (Subp); Set_Entity (Subp, Nam); - if Component_Type (Ret_Type) /= Any_Type then - Index_Node := - Make_Indexed_Component (Loc, - Prefix => - Make_Function_Call (Loc, - Name => New_Subp), - Expressions => Parameter_Associations (N)); + if (Is_Array_Type (Ret_Type) + and then Component_Type (Ret_Type) /= Any_Type) + or else + (Is_Access_Type (Ret_Type) + and then + Component_Type (Designated_Type (Ret_Type)) /= Any_Type) + then + if Needs_No_Actuals (Nam) then + + -- Indexed call to a parameterless function + + Index_Node := + Make_Indexed_Component (Loc, + Prefix => + Make_Function_Call (Loc, + Name => New_Subp), + Expressions => Parameter_Associations (N)); + else + -- An Ada 2005 prefixed call to a primitive operation + -- whose first parameter is the prefix. This prefix was + -- prepended to the parameter list, which is actually a + -- list of indices. Remove the prefix in order to build + -- the proper indexed component. + + Index_Node := + Make_Indexed_Component (Loc, + Prefix => + Make_Function_Call (Loc, + Name => New_Subp, + Parameter_Associations => + New_List + (Remove_Head (Parameter_Associations (N)))), + Expressions => Parameter_Associations (N)); + end if; -- Since we are correcting a node classification error made -- by the parser, we call Replace rather than Rewrite. @@ -3826,57 +5043,110 @@ package body Sem_Res is -- 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. + -- No_Recursion is in effect anyway, and do it only for source calls. - Scop := Current_Scope; + if Comes_From_Source (N) then + Scop := Current_Scope; - if Nam = Scop - and then not Restriction_Active (No_Recursion) - and then Check_Infinite_Recursion (N) - then - -- Here we detected and flagged an infinite recursion, so we do - -- not need to test the case below for further warnings. + -- Issue warning for possible infinite recursion in the absence + -- of the No_Recursion restriction. - null; + if Nam = Scop + and then not Restriction_Active (No_Recursion) + and then Check_Infinite_Recursion (N) + then + -- Here we detected and flagged an infinite recursion, so we do + -- not need to test the case below for further warnings. Also if + -- we now have a raise SE node, we are all done. - -- If call is to immediately containing subprogram, then check for - -- the case of a possible run-time detectable infinite recursion. + if Nkind (N) = N_Raise_Storage_Error then + return; + end if; - 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; + -- If call is to immediately containing subprogram, then check for + -- the case of a possible run-time detectable infinite recursion. - exit; - end if; + else + Scope_Loop : while Scop /= Standard_Standard loop + if Nam = Scop then + + -- Although in general case, recursion is not statically + -- checkable, the case of calling an immediately containing + -- subprogram is easy to catch. + + Check_Restriction (No_Recursion, N); + + -- If the recursive call is to a parameterless subprogram, + -- then even if we can't statically detect infinite + -- recursion, this is pretty suspicious, and we output a + -- warning. Furthermore, we will try later to detect some + -- cases here at run time by expanding checking code (see + -- Detect_Infinite_Recursion in package Exp_Ch6). + + -- If the recursive call is within a handler, do not emit a + -- warning, because this is a common idiom: loop until input + -- is correct, catch illegal input in handler and restart. + + if No (First_Formal (Nam)) + and then Etype (Nam) = Standard_Void_Type + and then not Error_Posted (N) + and then Nkind (Parent (N)) /= N_Exception_Handler + then + -- For the case of a procedure call. We give the message + -- only if the call is the first statement in a sequence + -- of statements, or if all previous statements are + -- simple assignments. This is simply a heuristic to + -- decrease false positives, without losing too many good + -- warnings. The idea is that these previous statements + -- may affect global variables the procedure depends on. + + if Nkind (N) = N_Procedure_Call_Statement + and then Is_List_Member (N) + then + declare + P : Node_Id; + begin + P := Prev (N); + while Present (P) loop + if Nkind (P) /= N_Assignment_Statement then + exit Scope_Loop; + end if; - Scop := Scope (Scop); - end loop; + Prev (P); + end loop; + end; + end if; + + -- Do not give warning if we are in a conditional context + + declare + K : constant Node_Kind := Nkind (Parent (N)); + begin + if (K = N_Loop_Statement + and then Present (Iteration_Scheme (Parent (N)))) + or else K = N_If_Statement + or else K = N_Elsif_Part + or else K = N_Case_Statement_Alternative + then + exit Scope_Loop; + end if; + end; + + -- Here warning is to be issued + + Set_Has_Recursive_Call (Nam); + Error_Msg_N + ("?possible infinite recursion!", N); + Error_Msg_N + ("\?Storage_Error may be raised at run time!", N); + end if; + + exit Scope_Loop; + end if; + + Scop := Scope (Scop); + end loop Scope_Loop; + end if; end if; -- If subprogram name is a predefined operator, it was given in @@ -3897,27 +5167,60 @@ package body Sem_Res is -- 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. + -- There are several notable exceptions: + + -- a) In init procs, the transient scope overhead is not needed, and is + -- even incorrect when the call is a nested initialization call for a + -- component whose expansion may generate adjust calls. However, if the + -- call is some other procedure call within an initialization procedure + -- (for example a call to Create_Task in the init_proc of the task + -- run-time record) a transient scope must be created around this call. + + -- b) Enumeration literal pseudo-calls need no transient scope + + -- c) Intrinsic subprograms (Unchecked_Conversion and source info + -- functions) do not use the secondary stack even though the return + -- type may be unconstrained. + + -- d) Calls to a build-in-place function, since such functions may + -- allocate their result directly in a target object, and cases where + -- the result does get allocated in the secondary stack are checked for + -- within the specialized Exp_Ch6 procedures for expanding those + -- build-in-place calls. + + -- e) If the subprogram is marked Inline_Always, then even if it returns + -- an unconstrained type the call does not require use of the secondary + -- stack. However, inlining will only take place if the body to inline + -- is already present. It may not be available if e.g. the subprogram is + -- declared in a child instance. + + -- If this is an initialization call for a type whose construction + -- uses the secondary stack, and it is not a nested call to initialize + -- a component, we do need to create a transient scope for it. We + -- check for this by traversing the type in Check_Initialization_Call. + + if Is_Inlined (Nam) + and then Has_Pragma_Inline_Always (Nam) + and then Nkind (Unit_Declaration_Node (Nam)) = N_Subprogram_Declaration + and then Present (Body_To_Inline (Unit_Declaration_Node (Nam))) + then + null; - -- 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. + elsif Ekind (Nam) = E_Enumeration_Literal + or else Is_Build_In_Place_Function (Nam) + or else Is_Intrinsic_Subprogram (Nam) + then + null; - if Expander_Active + elsif 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) + and then + (not Within_Init_Proc + or else + (not Is_Init_Proc (Nam) and then Ekind (Nam) /= E_Function)) then - Establish_Transient_Scope - (N, Sec_Stack => not Functions_Return_By_DSP_On_Target); + Establish_Transient_Scope (N, Sec_Stack => True); -- If the call appears within the bounds of a loop, it will -- be rewritten and reanalyzed, nothing left to do here. @@ -3949,9 +5252,9 @@ package body Sem_Res is 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. + -- 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); @@ -3959,9 +5262,78 @@ package body Sem_Res is -- Avoid validation, since it is a static function call + Generate_Reference (Nam, Subp); return; end if; + -- If the subprogram is not global, then kill all saved values and + -- checks. This is a bit conservative, since in many cases we could do + -- better, but it is not worth the effort. Similarly, we kill constant + -- values. However we do not need to do this for internal entities + -- (unless they are inherited user-defined subprograms), since they + -- are not in the business of molesting local values. + + -- If the flag Suppress_Value_Tracking_On_Calls is set, then we also + -- kill all checks and values for calls to global subprograms. This + -- takes care of the case where an access to a local subprogram is + -- taken, and could be passed directly or indirectly and then called + -- from almost any context. + + -- Note: we do not do this step till after resolving the actuals. That + -- way we still take advantage of the current value information while + -- scanning the actuals. + + -- We suppress killing values if we are processing the nodes associated + -- with N_Freeze_Entity nodes. Otherwise the declaration of a tagged + -- type kills all the values as part of analyzing the code that + -- initializes the dispatch tables. + + if Inside_Freezing_Actions = 0 + and then (not Is_Library_Level_Entity (Nam) + or else Suppress_Value_Tracking_On_Call + (Nearest_Dynamic_Scope (Current_Scope))) + and then (Comes_From_Source (Nam) + or else (Present (Alias (Nam)) + and then Comes_From_Source (Alias (Nam)))) + then + Kill_Current_Values; + end if; + + -- If we are warning about unread OUT parameters, this is the place to + -- set Last_Assignment for OUT and IN OUT parameters. We have to do this + -- after the above call to Kill_Current_Values (since that call clears + -- the Last_Assignment field of all local variables). + + if (Warn_On_Modified_Unread or Warn_On_All_Unread_Out_Parameters) + and then Comes_From_Source (N) + and then In_Extended_Main_Source_Unit (N) + then + declare + F : Entity_Id; + A : Node_Id; + + begin + F := First_Formal (Nam); + A := First_Actual (N); + while Present (F) and then Present (A) loop + if (Ekind (F) = E_Out_Parameter + or else + Ekind (F) = E_In_Out_Parameter) + and then Warn_On_Modified_As_Out_Parameter (F) + and then Is_Entity_Name (A) + and then Present (Entity (A)) + and then Comes_From_Source (N) + and then Safe_To_Capture_Value (N, Entity (A)) + then + Set_Last_Assignment (Entity (A), A); + end if; + + Next_Formal (F); + Next_Actual (A); + end loop; + end; + end if; + -- If the subprogram is a primitive operation, check whether or not -- it is a correct dispatching call. @@ -3970,18 +5342,53 @@ package body Sem_Res is then Check_Dispatching_Call (N); - elsif Is_Abstract (Nam) + elsif Ekind (Nam) /= E_Subprogram_Type + and then Is_Abstract_Subprogram (Nam) and then not In_Instance then Error_Msg_NE ("cannot call abstract subprogram &!", N, Nam); end if; + -- If this is a dispatching call, generate the appropriate reference, + -- for better source navigation in GPS. + + if Is_Overloadable (Nam) + and then Present (Controlling_Argument (N)) + then + Generate_Reference (Nam, Subp, 'R'); + + -- Normal case, not a dispatching call + + else + Generate_Reference (Nam, Subp); + end if; + if Is_Intrinsic_Subprogram (Nam) then Check_Intrinsic_Call (N); end if; + -- Check for violation of restriction No_Specific_Termination_Handlers + -- and warn on a potentially blocking call to Abort_Task. + + if Is_RTE (Nam, RE_Set_Specific_Handler) + or else + Is_RTE (Nam, RE_Specific_Handler) + then + Check_Restriction (No_Specific_Termination_Handlers, N); + + elsif Is_RTE (Nam, RE_Abort_Task) then + Check_Potentially_Blocking_Operation (N); + end if; + + -- Issue an error for a call to an eliminated subprogram + + Check_For_Eliminated_Subprogram (Subp, Nam); + + -- All done, evaluate call and deal with elaboration issues + Eval_Call (N); Check_Elab_Call (N); + Warn_On_Overlapping_Actuals (Nam, N); end Resolve_Call; ------------------------------- @@ -4035,18 +5442,17 @@ package body Sem_Res is elsif Root_Type (B_Typ) = Standard_Wide_Wide_Character then return; - -- If the entity is already set, this has already been resolved in - -- a generic context, or comes from expansion. Nothing else to do. + -- 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 + -- 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); @@ -4081,13 +5487,14 @@ package body Sem_Res is 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 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); @@ -4100,9 +5507,9 @@ package body Sem_Res is Generate_Reference (T, N, ' '); if T /= Any_Type then - if T = Any_String - or else T = Any_Composite - or else T = Any_Character + if T = Any_String or else + T = Any_Composite or else + T = Any_Character then if T = Any_Character then Ambiguous_Character (L); @@ -4119,8 +5526,8 @@ package body Sem_Res is Check_Unset_Reference (L); Check_Unset_Reference (R); Generate_Operator_Reference (N, T); + Check_Low_Bound_Tested (N); Eval_Relational_Op (N); - Check_Direct_Boolean_Op (N); end if; end if; end Resolve_Comparison_Op; @@ -4132,12 +5539,31 @@ package body Sem_Res is 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); + Else_Expr : Node_Id := Next (Then_Expr); begin - Resolve (Condition, Standard_Boolean); + Resolve (Condition, Any_Boolean); Resolve (Then_Expr, Typ); - Resolve (Else_Expr, Typ); + + -- If ELSE expression present, just resolve using the determined type + + if Present (Else_Expr) then + Resolve (Else_Expr, Typ); + + -- If no ELSE expression is present, root type must be Standard.Boolean + -- and we provide a Standard.True result converted to the appropriate + -- Boolean type (in case it is a derived boolean type). + + elsif Root_Type (Typ) = Standard_Boolean then + Else_Expr := + Convert_To (Typ, New_Occurrence_Of (Standard_True, Sloc (N))); + Analyze_And_Resolve (Else_Expr, Typ); + Append_To (Expressions (N), Else_Expr); + + else + Error_Msg_N ("can only omit ELSE expression in Boolean case", N); + Append_To (Expressions (N), Error); + end if; Set_Etype (N, Typ); Eval_Conditional_Expression (N); @@ -4264,9 +5690,9 @@ package body Sem_Res is 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. + -- 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) @@ -4306,15 +5732,15 @@ package body Sem_Res is -- 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. + -- 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 In_Spec_Expression and then not Is_Imported (E) then @@ -4365,11 +5791,11 @@ package body Sem_Res is 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). + -- 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 -- @@ -4409,7 +5835,8 @@ package body Sem_Res is begin if not Has_Discriminants (Tsk) or else (not Is_Entity_Name (Lo) - and then not Is_Entity_Name (Hi)) + and then + not Is_Entity_Name (Hi)) then return Entry_Index_Type (E); @@ -4445,23 +5872,23 @@ package body Sem_Res is 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. + -- 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. + -- 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 @@ -4471,7 +5898,6 @@ package body Sem_Res is -- the type in the same declarative part. Tsk := Next_Entity (S); - while Etype (Tsk) /= S loop Next_Entity (Tsk); end loop; @@ -4499,9 +5925,9 @@ package body Sem_Res is 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. + -- Use the entry name (which must be unique at this point) to find + -- the prefix that returns the corresponding task type or protected + -- type. declare Pref : constant Node_Id := Prefix (Entry_Name); @@ -4511,9 +5937,7 @@ package body Sem_Res is begin Get_First_Interp (Pref, I, It); - while Present (It.Typ) loop - if Scope (Ent) = It.Typ then Set_Etype (Pref, It.Typ); exit; @@ -4533,8 +5957,8 @@ package body Sem_Res is 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. + -- 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); @@ -4559,8 +5983,8 @@ package body Sem_Res is Was_Over : Boolean; begin - -- We kill all checks here, because it does not seem worth the - -- effort to do anything better, an entry call is a big operation. + -- We kill all checks here, because it does not seem worth the effort to + -- do anything better, an entry call is a big operation. Kill_All_Checks; @@ -4582,9 +6006,7 @@ package body Sem_Res is 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); @@ -4702,17 +6124,17 @@ package body Sem_Res is 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. + -- 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. + -- 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) @@ -4736,13 +6158,12 @@ package body Sem_Res is Set_Analyzed (N, True); -- Protected functions can return on the secondary stack, in which - -- case we must trigger the transient scope mechanism + -- 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); + Establish_Transient_Scope (N, Sec_Stack => True); end if; end Resolve_Entry_Call; @@ -4750,13 +6171,12 @@ package body Sem_Res is -- 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. + -- 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); @@ -4776,24 +6196,21 @@ package body Sem_Res is function Find_Unique_Access_Type return Entity_Id is Acc : Entity_Id; E : Entity_Id; - S : Entity_Id := Current_Scope; + S : Entity_Id; begin if Ekind (Etype (R)) = E_Allocator_Type then Acc := Designated_Type (Etype (R)); - elsif Ekind (Etype (L)) = E_Allocator_Type then Acc := Designated_Type (Etype (L)); - else return Empty; end if; + S := Current_Scope; while S /= Standard_Standard loop E := First_Entity (S); - while Present (E) loop - if Is_Type (E) and then Is_Access_Type (E) and then Ekind (E) /= E_Allocator_Type @@ -4822,12 +6239,10 @@ package body Sem_Res is 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 @@ -4839,6 +6254,7 @@ package body Sem_Res is elsif T = Any_Access or else Ekind (T) = E_Allocator_Type + or else Ekind (T) = E_Access_Attribute_Type then T := Find_Unique_Access_Type; @@ -4852,18 +6268,27 @@ package body Sem_Res is Resolve (L, T); Resolve (R, T); + -- If the unique type is a class-wide type then it will be expanded + -- into a dispatching call to the predefined primitive. Therefore we + -- check here for potential violation of such restriction. + + if Is_Class_Wide_Type (T) then + Check_Restriction (No_Dispatching_Calls, N); + end if; + if Warn_On_Redundant_Constructs and then Comes_From_Source (N) and then Is_Entity_Name (R) and then Entity (R) = Standard_True and then Comes_From_Source (R) then - Error_Msg_N ("comparison with True is redundant?", R); + Error_Msg_N ("?comparison with True is redundant!", R); end if; Check_Unset_Reference (L); Check_Unset_Reference (R); Generate_Operator_Reference (N, T); + Check_Low_Bound_Tested (N); -- If this is an inequality, it may be the implicit inequality -- created for a user-defined operation, in which case the corres- @@ -4877,13 +6302,45 @@ package body Sem_Res is (Corresponding_Equality (Entity (N))) then Eval_Relational_Op (N); + elsif Nkind (N) = N_Op_Ne - and then Is_Abstract (Entity (N)) + and then Is_Abstract_Subprogram (Entity (N)) then Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N)); end if; - Check_Direct_Boolean_Op (N); + -- Ada 2005: If one operand is an anonymous access type, convert the + -- other operand to it, to ensure that the underlying types match in + -- the back-end. Same for access_to_subprogram, and the conversion + -- verifies that the types are subtype conformant. + + -- We apply the same conversion in the case one of the operands is a + -- private subtype of the type of the other. + + -- Why the Expander_Active test here ??? + + if Expander_Active + and then + (Ekind (T) = E_Anonymous_Access_Type + or else Ekind (T) = E_Anonymous_Access_Subprogram_Type + or else Is_Private_Type (T)) + then + if Etype (L) /= T then + Rewrite (L, + Make_Unchecked_Type_Conversion (Sloc (L), + Subtype_Mark => New_Occurrence_Of (T, Sloc (L)), + Expression => Relocate_Node (L))); + Analyze_And_Resolve (L, T); + end if; + + if (Etype (R)) /= T then + Rewrite (R, + Make_Unchecked_Type_Conversion (Sloc (R), + Subtype_Mark => New_Occurrence_Of (Etype (L), Sloc (R)), + Expression => Relocate_Node (R))); + Analyze_And_Resolve (R, T); + end if; + end if; end if; end Resolve_Equality_Op; @@ -4899,30 +6356,7 @@ package body Sem_Res is It : Interp; begin - -- Now that we know the type, check that this is not dereference of an - -- uncompleted type. Note that this is not entirely correct, because - -- dereferences of private types are legal in default expressions. This - -- exception is taken care of in Check_Fully_Declared. - - -- This consideration also applies to similar checks for allocators, - -- qualified expressions, and type conversions. - - -- An additional exception concerns other per-object expressions that - -- are not directly related to component declarations, in particular - -- representation pragmas for tasks. These will be per-object - -- expressions if they depend on discriminants or some global entity. - -- If the task has access discriminants, the designated type may be - -- incomplete at the point the expression is resolved. This resolution - -- takes place within the body of the initialization procedure, where - -- the discriminant is replaced by its discriminal. - - if Is_Entity_Name (Prefix (N)) - and then Ekind (Entity (Prefix (N))) = E_In_Parameter - then - null; - else - Check_Fully_Declared (Typ, N); - end if; + Check_Fully_Declared_Prefix (Typ, P); if Is_Overloaded (P) then @@ -4933,7 +6367,6 @@ package body Sem_Res is 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; @@ -4996,9 +6429,8 @@ package body Sem_Res is 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. + -- Note: No Eval processing is required for an explicit dereference, + -- because such a name can never be static. end Resolve_Explicit_Dereference; @@ -5027,12 +6459,7 @@ package body Sem_Res is begin Get_First_Interp (P, I, It); - - -- the task has access discriminants, the designated type may be - -- incomplete at the point the expression is resolved. This resolution - -- takes place within the body of the initialization proc 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) @@ -5081,8 +6508,14 @@ package body Sem_Res is end if; -- If name was overloaded, set component type correctly now + -- If a misplaced call to an entry family (which has no index types) + -- return. Error will be diagnosed from calling context. - Set_Etype (N, Component_Type (Array_Type)); + if Is_Array_Type (Array_Type) then + Set_Etype (N, Component_Type (Array_Type)); + else + return; + end if; Index := First_Index (Array_Type); Expr := First (Expressions (N)); @@ -5111,7 +6544,18 @@ package body Sem_Res is end loop; end if; - Eval_Indexed_Component (N); + -- Do not generate the warning on suspicious index if we are analyzing + -- package Ada.Tags; otherwise we will report the warning with the + -- Prims_Ptr field of the dispatch table. + + if Scope (Etype (Prefix (N))) = Standard_Standard + or else not + Is_RTU (Cunit_Entity (Get_Source_Unit (Etype (Prefix (N)))), + Ada_Tags) + then + Warn_On_Suspicious_Index (Name, First (Expressions (N))); + Eval_Indexed_Component (N); + end if; end Resolve_Indexed_Component; ----------------------------- @@ -5136,7 +6580,6 @@ package body Sem_Res is begin Op := Entity (N); - while Scope (Op) /= Standard_Standard loop Op := Homonym (Op); pragma Assert (Present (Op)); @@ -5171,8 +6614,8 @@ package body Sem_Res is elsif Typ /= Etype (Left_Opnd (N)) or else Typ /= Etype (Right_Opnd (N)) then - -- Add explicit conversion where needed, and save interpretations - -- in case operands are overloaded. + -- Add explicit conversion where needed, and save interpretations in + -- case operands are overloaded. Arg1 := Convert_To (Typ, Left_Opnd (N)); Arg2 := Convert_To (Typ, Right_Opnd (N)); @@ -5214,7 +6657,6 @@ package body Sem_Res is begin Op := Entity (N); - while Scope (Op) /= Standard_Standard loop Op := Homonym (Op); pragma Assert (Present (Op)); @@ -5245,6 +6687,8 @@ package body Sem_Res is B_Typ : Entity_Id; begin + Check_No_Direct_Boolean_Operators (N); + -- 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). @@ -5287,7 +6731,6 @@ package body Sem_Res is Set_Etype (N, B_Typ); Generate_Operator_Reference (N, B_Typ); Eval_Logical_Op (N); - Check_Direct_Boolean_Op (N); end Resolve_Logical_Op; --------------------------- @@ -5301,22 +6744,80 @@ package body Sem_Res is procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id) is pragma Warnings (Off, Typ); - L : constant Node_Id := Left_Opnd (N); - R : constant Node_Id := Right_Opnd (N); + L : constant Node_Id := Left_Opnd (N); + R : constant Node_Id := Right_Opnd (N); T : Entity_Id; + procedure Resolve_Set_Membership; + -- Analysis has determined a unique type for the left operand. + -- Use it to resolve the disjuncts. + + ---------------------------- + -- Resolve_Set_Membership -- + ---------------------------- + + procedure Resolve_Set_Membership is + Alt : Node_Id; + + begin + Resolve (L, Etype (L)); + + Alt := First (Alternatives (N)); + while Present (Alt) loop + + -- Alternative is an expression, a range + -- or a subtype mark. + + if not Is_Entity_Name (Alt) + or else not Is_Type (Entity (Alt)) + then + Resolve (Alt, Etype (L)); + end if; + + Next (Alt); + end loop; + end Resolve_Set_Membership; + + -- Start of processing for Resolve_Membership_Op + begin if L = Error or else R = Error then return; end if; - if not Is_Overloaded (R) + if Present (Alternatives (N)) then + Resolve_Set_Membership; + return; + + elsif not Is_Overloaded (R) and then (Etype (R) = Universal_Integer or else Etype (R) = Universal_Real) and then Is_Overloaded (L) then T := Etype (R); + + -- Ada 2005 (AI-251): Support the following case: + + -- type I is interface; + -- type T is tagged ... + + -- function Test (O : I'Class) is + -- begin + -- return O in T'Class. + -- end Test; + + -- In this case we have nothing else to do. The membership test will be + -- done at run-time. + + elsif Ada_Version >= Ada_05 + and then Is_Class_Wide_Type (Etype (L)) + and then Is_Interface (Etype (L)) + and then Is_Class_Wide_Type (Etype (R)) + and then not Is_Interface (Etype (R)) + then + return; + else T := Intersect_Types (L, R); end if; @@ -5345,9 +6846,11 @@ package body Sem_Res is ------------------ procedure Resolve_Null (N : Node_Id; Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + begin -- Handle restriction against anonymous null access values This - -- restriction can be turned off using -gnatdh. + -- restriction can be turned off using -gnatdj. -- Ada 2005 (AI-231): Remove restriction @@ -5356,12 +6859,11 @@ package body Sem_Res is 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 + -- In the common case of a call which uses an explicitly null value + -- for an access parameter, give specialized error message. - if Nkind (Parent (N)) = N_Procedure_Call_Statement - or else - Nkind (Parent (N)) = N_Function_Call + if Nkind_In (Parent (N), N_Procedure_Call_Statement, + N_Function_Call) then Error_Msg_N ("null is not allowed as argument for an access parameter", N); @@ -5374,9 +6876,29 @@ package body Sem_Res is 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. + -- Ada 2005 (AI-231): Generate the null-excluding check in case of + -- assignment to a null-excluding object + + if Ada_Version >= Ada_05 + and then Can_Never_Be_Null (Typ) + and then Nkind (Parent (N)) = N_Assignment_Statement + then + if not Inside_Init_Proc then + Insert_Action + (Compile_Time_Constraint_Error (N, + "(Ada 2005) null not allowed in null-excluding objects?"), + Make_Raise_Constraint_Error (Loc, + Reason => CE_Access_Check_Failed)); + else + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Reason => CE_Access_Check_Failed)); + end if; + end if; + + -- In a distributed context, null for a remote access to subprogram may + -- need to be replaced with a special record aggregate. In this case, + -- return after having done the transformation. if (Ekind (Typ) = E_Record_Type or else Is_Remote_Access_To_Subprogram_Type (Typ)) @@ -5395,128 +6917,204 @@ package body Sem_Res is ----------------------- 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. + -- We wish to avoid deep recursion, because concatenations are often + -- deeply nested, as in A&B&...&Z. Therefore, we walk down the left + -- operands nonrecursively until we find something that is not a simple + -- concatenation (A in this case). We resolve that, and then walk back + -- up the tree following Parent pointers, calling Resolve_Op_Concat_Rest + -- to do the rest of the work at each level. The Parent pointers allow + -- us to avoid recursion, and thus avoid running out of memory. See also + -- Sem_Ch4.Analyze_Concatenation, where a similar approach is used. - ------------------------------- - -- Resolve_Concatenation_Arg -- - ------------------------------- + NN : Node_Id := N; + Op1 : Node_Id; - 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; + begin + -- The following code is equivalent to: - elsif Has_Compatible_Type (Arg, Component_Type (Typ)) then + -- Resolve_Op_Concat_First (NN, Typ); + -- Resolve_Op_Concat_Arg (N, ...); + -- Resolve_Op_Concat_Rest (N, Typ); - 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); + -- where the Resolve_Op_Concat_Arg call recurses back here if the left + -- operand is a concatenation. - else - Error_Msg_N ("ambiguous aggregate must be qualified", Arg); - Set_Etype (Arg, Any_Type); - end if; + -- Walk down left operands + + loop + Resolve_Op_Concat_First (NN, Typ); + Op1 := Left_Opnd (NN); + exit when not (Nkind (Op1) = N_Op_Concat + and then not Is_Array_Type (Component_Type (Typ)) + and then Entity (Op1) = Entity (NN)); + NN := Op1; + end loop; + + -- Now (given the above example) NN is A&B and Op1 is A + + -- First resolve Op1 ... + + Resolve_Op_Concat_Arg (NN, Op1, Typ, Is_Component_Left_Opnd (NN)); + + -- ... then walk NN back up until we reach N (where we started), calling + -- Resolve_Op_Concat_Rest along the way. + + loop + Resolve_Op_Concat_Rest (NN, Typ); + exit when NN = N; + NN := Parent (NN); + end loop; + end Resolve_Op_Concat; + + --------------------------- + -- Resolve_Op_Concat_Arg -- + --------------------------- + + procedure Resolve_Op_Concat_Arg + (N : Node_Id; + Arg : Node_Id; + Typ : Entity_Id; + Is_Comp : Boolean) + is + Btyp : constant Entity_Id := Base_Type (Typ); + + begin + if In_Instance then + if Is_Comp + or else (not Is_Overloaded (Arg) + and then Etype (Arg) /= Any_Composite + and then Covers (Component_Type (Typ), Etype (Arg))) + then + Resolve (Arg, Component_Type (Typ)); + else + Resolve (Arg, Btyp); + end if; + elsif Has_Compatible_Type (Arg, Component_Type (Typ)) then + if Nkind (Arg) = N_Aggregate + and then Is_Composite_Type (Component_Type (Typ)) + then + if Is_Private_Type (Component_Type (Typ)) then + Resolve (Arg, Btyp); else - 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); + Error_Msg_N ("ambiguous aggregate must be qualified", Arg); + Set_Etype (Arg, Any_Type); + end if; + + else + if Is_Overloaded (Arg) + and then Has_Compatible_Type (Arg, Typ) + and then Etype (Arg) /= Any_Type + then + declare + I : Interp_Index; + It : Interp; + Func : Entity_Id; - declare - I : Interp_Index; - It : Interp; + begin + Get_First_Interp (Arg, I, It); + Func := It.Nam; + Get_Next_Interp (I, It); + + -- Special-case the error message when the overloading is + -- caused by a function that yields an array and can be + -- called without parameters. + + if It.Nam = Func then + Error_Msg_Sloc := Sloc (Func); + Error_Msg_N ("ambiguous call to function#", Arg); + Error_Msg_NE + ("\\interpretation as call yields&", Arg, Typ); + Error_Msg_NE + ("\\interpretation as indexing of call yields&", + Arg, Component_Type (Typ)); - begin + else + Error_Msg_N + ("ambiguous operand for concatenation!", Arg); Get_First_Interp (Arg, I, It); - while Present (It.Nam) loop + Error_Msg_Sloc := Sloc (It.Nam); - if Base_Type (Etype (It.Nam)) = Base_Type (Typ) - or else Base_Type (Etype (It.Nam)) = + if Base_Type (It.Typ) = Base_Type (Typ) + or else Base_Type (It.Typ) = Base_Type (Component_Type (Typ)) then - Error_Msg_Sloc := Sloc (It.Nam); - Error_Msg_N ("\possible interpretation#", Arg); + Error_Msg_N -- CODEFIX + ("\\possible interpretation#", Arg); end if; Get_Next_Interp (I, It); end loop; - end; - end if; - - Resolve (Arg, Component_Type (Typ)); + end if; + end; + end if; - if Nkind (Arg) = N_String_Literal then - Set_Etype (Arg, Component_Type (Typ)); - 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; + if Nkind (Arg) = N_String_Literal then + Set_Etype (Arg, Component_Type (Typ)); end if; - else - Resolve (Arg, Btyp); + if Arg = Left_Opnd (N) then + Set_Is_Component_Left_Opnd (N); + else + Set_Is_Component_Right_Opnd (N); + end if; end if; - Check_Unset_Reference (Arg); - end Resolve_Concatenation_Arg; + else + Resolve (Arg, Btyp); + end if; + + Check_Unset_Reference (Arg); + end Resolve_Op_Concat_Arg; - -- Start of processing for Resolve_Op_Concat + ----------------------------- + -- Resolve_Op_Concat_First -- + ----------------------------- + + procedure Resolve_Op_Concat_First (N : Node_Id; Typ : Entity_Id) is + Btyp : constant Entity_Id := Base_Type (Typ); + Op1 : constant Node_Id := Left_Opnd (N); + Op2 : constant Node_Id := Right_Opnd (N); begin + -- The parser folds an enormous sequence of concatenations of string + -- literals into "" & "...", where the Is_Folded_In_Parser flag is set + -- in the right operand. If the expression resolves to a predefined "&" + -- operator, all is well. Otherwise, the parser's folding is wrong, so + -- we give an error. See P_Simple_Expression in Par.Ch4. + + if Nkind (Op2) = N_String_Literal + and then Is_Folded_In_Parser (Op2) + and then Ekind (Entity (N)) = E_Function + then + pragma Assert (Nkind (Op1) = N_String_Literal -- should be "" + and then String_Length (Strval (Op1)) = 0); + Error_Msg_N ("too many user-defined concatenations", N); + return; + end if; + Set_Etype (N, Btyp); if Is_Limited_Composite (Btyp) then Error_Msg_N ("concatenation not available for limited array", N); Explain_Limited_Type (Btyp, N); end if; + end Resolve_Op_Concat_First; - -- 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. + ---------------------------- + -- Resolve_Op_Concat_Rest -- + ---------------------------- - 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; + procedure Resolve_Op_Concat_Rest (N : Node_Id; Typ : Entity_Id) is + Op1 : constant Node_Id := Left_Opnd (N); + Op2 : constant Node_Id := Right_Opnd (N); - 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; + begin + Resolve_Op_Concat_Arg (N, Op2, Typ, Is_Component_Right_Opnd (N)); Generate_Operator_Reference (N, Typ); @@ -5524,9 +7122,9 @@ package body Sem_Res is 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 this is not a static concatenation, but the result is a string + -- type (and not an array of strings) ensure that static string operands + -- have their subtypes properly constructed. if Nkind (N) /= N_String_Literal and then Is_Character_Type (Component_Type (Typ)) @@ -5534,7 +7132,7 @@ package body Sem_Res is Set_String_Literal_Subtype (Op1, Typ); Set_String_Literal_Subtype (Op2, Typ); end if; - end Resolve_Op_Concat; + end Resolve_Op_Concat_Rest; ---------------------- -- Resolve_Op_Expon -- @@ -5544,7 +7142,7 @@ package body Sem_Res is B_Typ : constant Entity_Id := Base_Type (Typ); begin - -- Catch attempts to do fixed-point exponentation with universal + -- Catch attempts to do fixed-point exponentiation with universal -- operands, which is a case where the illegality is not caught during -- normal operator analysis. @@ -5605,6 +7203,10 @@ package body Sem_Res is -- and the not in question is the left operand of this operation. -- Note that if the not is in parens, then false is returned. + ----------------------- + -- Parent_Is_Boolean -- + ----------------------- + function Parent_Is_Boolean return Boolean is begin if Paren_Count (N) /= 0 then @@ -5624,7 +7226,7 @@ package body Sem_Res is N_In | N_Not_In | N_And_Then | - N_Or_Else => + N_Or_Else => return Left_Opnd (Parent (N)) = N; @@ -5647,11 +7249,15 @@ package body Sem_Res is B_Typ := Base_Type (Typ); end if; + -- Straightforward case of incorrect arguments + if not Valid_Boolean_Arg (Typ) then Error_Msg_N ("invalid operand type for operator&", N); Set_Etype (N, Any_Type); return; + -- Special case of probable missing parens + elsif Typ = Universal_Integer or else Typ = Any_Modular then if Parent_Is_Boolean then Error_Msg_N @@ -5665,13 +7271,33 @@ package body Sem_Res is Set_Etype (N, Any_Type); return; + -- OK resolution of not + else - if not Is_Boolean_Type (Typ) + -- Warn if non-boolean types involved. This is a case like not a < b + -- where a and b are modular, where we will get (not a) < b and most + -- likely not (a < b) was intended. + + if Warn_On_Questionable_Missing_Parens + and then not Is_Boolean_Type (Typ) and then Parent_Is_Boolean then - Error_Msg_N ("?not expression should be parenthesized here", N); + Error_Msg_N ("?not expression should be parenthesized here!", N); + end if; + + -- Warn on double negation if checking redundant constructs + + if Warn_On_Redundant_Constructs + and then Comes_From_Source (N) + and then Comes_From_Source (Right_Opnd (N)) + and then Root_Type (Typ) = Standard_Boolean + and then Nkind (Right_Opnd (N)) = N_Op_Not + then + Error_Msg_N ("redundant double negation?", N); end if; + -- Complete resolution and evaluation of NOT + Resolve (Right_Opnd (N), B_Typ); Check_Unset_Reference (Right_Opnd (N)); Set_Etype (N, B_Typ); @@ -5708,9 +7334,16 @@ package body Sem_Res is 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) + -- class-wide matching is not allowed. However, if the qualifying + -- type is specific and the expression has a class-wide type, it + -- may still be okay, since it can be the result of the expansion + -- of a call to a dispatching function, so we also have to check + -- class-wideness of the type of the expression's original node. + + if (Is_Class_Wide_Type (Target_Typ) + or else + (Is_Class_Wide_Type (Etype (Expr)) + and then Is_Class_Wide_Type (Etype (Original_Node (Expr))))) and then Base_Type (Etype (Expr)) /= Base_Type (Target_Typ) then Wrong_Type (Expr, Target_Typ); @@ -5756,6 +7389,15 @@ package body Sem_Res is Check_Non_Static_Context (L); Check_Non_Static_Context (H); + -- Check for an ambiguous range over character literals. This will + -- happen with a membership test involving only literals. + + if Typ = Any_Character then + Ambiguous_Character (L); + Set_Etype (N, Any_Type); + return; + end if; + -- If bounds are static, constant-fold them, so size computations -- are identical between front-end and back-end. Do not perform this -- transformation while analyzing generic units, as type information @@ -5818,7 +7460,7 @@ package body Sem_Res is and then Warn_On_Bad_Fixed_Value then Error_Msg_N - ("static fixed-point value is not a multiple of Small?", + ("?static fixed-point value is not a multiple of Small!", N); end if; @@ -5870,7 +7512,7 @@ package body Sem_Res is -- sequences that otherwise fail to notice the modification. if Is_Entity_Name (P) and then Treat_As_Volatile (Entity (P)) then - Note_Possible_Modification (P); + Note_Possible_Modification (P, Sure => False); end if; end Resolve_Reference; @@ -5926,10 +7568,16 @@ package body Sem_Res is end if; if Is_Record_Type (T) then - Comp := First_Entity (T); - while Present (Comp) loop + -- The visible components of a class-wide type are those of + -- the root type. + + if Is_Class_Wide_Type (T) then + T := Etype (T); + end if; + Comp := First_Entity (T); + while Present (Comp) loop if Chars (Comp) = Chars (S) and then Covers (Etype (Comp), Typ) then @@ -5951,13 +7599,21 @@ package body Sem_Res is else It1 := It; - if Scope (Comp1) /= It1.Typ then + -- There may be an implicit dereference. Retrieve + -- designated record type. + + if Is_Access_Type (It1.Typ) then + T := Designated_Type (It1.Typ); + else + T := It1.Typ; + end if; + + if Scope (Comp1) /= T then -- Resolution chooses the new interpretation. -- Find the component with the right name. - Comp1 := First_Entity (It1.Typ); - + Comp1 := First_Entity (T); while Present (Comp1) and then Chars (Comp1) /= Chars (S) loop @@ -5980,7 +7636,7 @@ package body Sem_Res is Resolve (P, It1.Typ); Set_Etype (N, Typ); - Set_Entity (S, Comp1); + Set_Entity_With_Style_Check (S, Comp1); else -- Resolve prefix with its type @@ -5988,12 +7644,23 @@ package body Sem_Res is Resolve (P, T); end if; - -- If prefix is an access type, the node will be transformed into - -- an explicit dereference during expansion. The type of the node - -- is the designated type of that of the prefix. + -- Generate cross-reference. We needed to wait until full overloading + -- resolution was complete to do this, since otherwise we can't tell if + -- we are an lvalue or not. + + if May_Be_Lvalue (N) then + Generate_Reference (Entity (S), S, 'm'); + else + Generate_Reference (Entity (S), S, 'r'); + end if; + + -- If prefix is an access type, the node will be transformed into an + -- explicit dereference during expansion. The type of the node is the + -- designated type of that of the prefix. if Is_Access_Type (Etype (P)) then T := Designated_Type (Etype (P)); + Check_Fully_Declared_Prefix (T, P); else T := Etype (P); end if; @@ -6069,6 +7736,82 @@ package body Sem_Res is Resolve (L, B_Typ); Resolve (R, B_Typ); + -- Check for issuing warning for always False assert/check, this happens + -- when assertions are turned off, in which case the pragma Assert/Check + -- was transformed into: + + -- if False and then then ... + + -- and we detect this pattern + + if Warn_On_Assertion_Failure + and then Is_Entity_Name (R) + and then Entity (R) = Standard_False + and then Nkind (Parent (N)) = N_If_Statement + and then Nkind (N) = N_And_Then + and then Is_Entity_Name (L) + and then Entity (L) = Standard_False + then + declare + Orig : constant Node_Id := Original_Node (Parent (N)); + + begin + if Nkind (Orig) = N_Pragma + and then Pragma_Name (Orig) = Name_Assert + then + -- Don't want to warn if original condition is explicit False + + declare + Expr : constant Node_Id := + Original_Node + (Expression + (First (Pragma_Argument_Associations (Orig)))); + begin + if Is_Entity_Name (Expr) + and then Entity (Expr) = Standard_False + then + null; + else + -- Issue warning. Note that we don't want to make this + -- an unconditional warning, because if the assert is + -- within deleted code we do not want the warning. But + -- we do not want the deletion of the IF/AND-THEN to + -- take this message with it. We achieve this by making + -- sure that the expanded code points to the Sloc of + -- the expression, not the original pragma. + + Error_Msg_N ("?assertion would fail at run-time", Orig); + end if; + end; + + -- Similar processing for Check pragma + + elsif Nkind (Orig) = N_Pragma + and then Pragma_Name (Orig) = Name_Check + then + -- Don't want to warn if original condition is explicit False + + declare + Expr : constant Node_Id := + Original_Node + (Expression + (Next (First + (Pragma_Argument_Associations (Orig))))); + begin + if Is_Entity_Name (Expr) + and then Entity (Expr) = Standard_False + then + null; + else + Error_Msg_N ("?check would fail at run-time", Orig); + end if; + end; + end if; + end; + end if; + + -- Continue with processing of short circuit + Check_Unset_Reference (L); Check_Unset_Reference (R); @@ -6089,8 +7832,8 @@ package body Sem_Res is begin if Is_Overloaded (Name) then - -- Use the context type to select the prefix that yields the - -- correct array type. + -- Use the context type to select the prefix that yields the correct + -- array type. declare I : Interp_Index; @@ -6101,9 +7844,7 @@ package body Sem_Res is 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) @@ -6143,11 +7884,11 @@ package body Sem_Res is Apply_Access_Check (N); Array_Type := Designated_Type (Array_Type); - -- If the prefix is an access to an unconstrained array, we must - -- use the actual subtype of the object to perform the index checks. - -- The object denoted by the prefix is implicit in the node, so we - -- build an explicit representation for it in order to compute the - -- actual subtype. + -- If the prefix is an access to an unconstrained array, we must use + -- the actual subtype of the object to perform the index checks. The + -- object denoted by the prefix is implicit in the node, so we build + -- an explicit representation for it in order to compute the actual + -- subtype. if not Is_Constrained (Array_Type) then Remove_Side_Effects (Prefix (N)); @@ -6168,25 +7909,73 @@ package body Sem_Res is and then not Is_Constrained (Etype (Name))) then Array_Type := Get_Actual_Subtype (Name); + + -- If the name is a selected component that depends on discriminants, + -- build an actual subtype for it. This can happen only when the name + -- itself is overloaded; otherwise the actual subtype is created when + -- the selected component is analyzed. + + elsif Nkind (Name) = N_Selected_Component + and then Full_Analysis + and then Depends_On_Discriminant (First_Index (Array_Type)) + then + declare + Act_Decl : constant Node_Id := + Build_Actual_Subtype_Of_Component (Array_Type, Name); + begin + Insert_Action (N, Act_Decl); + Array_Type := Defining_Identifier (Act_Decl); + end; + + -- Maybe this should just be "else", instead of checking for the + -- specific case of slice??? This is needed for the case where + -- the prefix is an Image attribute, which gets expanded to a + -- slice, and so has a constrained subtype which we want to use + -- for the slice range check applied below (the range check won't + -- get done if the unconstrained subtype of the 'Image is used). + + elsif Nkind (Name) = N_Slice then + Array_Type := Etype (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. Else resolve the bounds, and apply needed checks. + -- If the range is specified by a subtype mark, no resolution is + -- necessary. Else resolve the bounds, and apply needed checks. if not Is_Entity_Name (Drange) then Index := First_Index (Array_Type); Resolve (Drange, Base_Type (Etype (Index))); - if Nkind (Drange) = N_Range then + if Nkind (Drange) = N_Range + + -- Do not apply the range check to nodes associated with the + -- frontend expansion of the dispatch table. We first check + -- if Ada.Tags is already loaded to void the addition of an + -- undesired dependence on such run-time unit. + + and then + (not Tagged_Type_Expansion + or else not + (RTU_Loaded (Ada_Tags) + and then Nkind (Prefix (N)) = N_Selected_Component + and then Present (Entity (Selector_Name (Prefix (N)))) + and then Entity (Selector_Name (Prefix (N))) = + RTE_Record_Component (RE_Prims_Ptr))) + then Apply_Range_Check (Drange, Etype (Index)); end if; end if; Set_Slice_Subtype (N); + + if Nkind (Drange) = N_Range then + Warn_On_Suspicious_Index (Name, Low_Bound (Drange)); + Warn_On_Suspicious_Index (Name, High_Bound (Drange)); + end if; + Eval_Slice (N); end Resolve_Slice; @@ -6206,13 +7995,13 @@ package body Sem_Res is 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. + -- 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 + -- 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 + -- 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 ??? @@ -6227,24 +8016,25 @@ package body Sem_Res is or else Typ = Standard_Wide_Wide_String) and then Nkind (Original_Node (N)) /= N_String_Literal); - -- If the resolving type is itself a string literal subtype, we - -- can just reuse it, since there is no point in creating another. + -- If 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 + and then not Nkind_In (Original_Node (N), N_Character_Literal, + N_Attribute_Reference, + N_Qualified_Expression, + N_Type_Conversion) then Subtype_Id := Typ; -- Otherwise we must create a string literal subtype. Note that the -- whole idea of string literal subtypes is simply to avoid the need -- for building a full fledged array subtype for each literal. + else Set_String_Literal_Subtype (N, Typ); Subtype_Id := Etype (N); @@ -6265,20 +8055,20 @@ package body Sem_Res is return; end if; - -- The validity of a null string has been checked in the - -- call to Eval_String_Literal. + -- 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. + -- 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 + -- If the type is bit-packed, then we always transform the string -- literal into a full fledged aggregate. elsif Is_Bit_Packed_Array (Typ) then @@ -6295,14 +8085,14 @@ package body Sem_Res is if R_Typ = Standard_Wide_Wide_Character then null; - -- For the case of Standard.String, or any other type whose - -- component type is Standard.Character, we must make sure that - -- there are no wide characters in the string, i.e. that it is - -- entirely composed of characters in range of type Character. + -- For the case of Standard.String, or any other type whose component + -- type is Standard.Character, we must make sure that there are no + -- wide characters in the string, i.e. that it is entirely composed + -- of characters in range of type Character. - -- If the string literal is the result of a static concatenation, - -- the test has already been performed on the components, and need - -- not be repeated. + -- 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 @@ -6312,7 +8102,9 @@ package body Sem_Res is -- 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. + -- a token, right under the offending wide character. Not + -- quite clear if this is right wrt wide character encoding + -- sequences, but it's only an error message! Error_Msg ("literal out of range of type Standard.Character", @@ -6358,17 +8150,15 @@ package body Sem_Res is 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 + -- 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_Character - or else R_Typ = Standard_Wide_Character - or else R_Typ = Standard_Wide_Wide_Character - then + if Is_Standard_Character_Type (R_Typ) then + -- Check for the case of full range, where we are definitely OK if Component_Type (Typ) = Base_Type (Component_Type (Typ)) then @@ -6417,9 +8207,9 @@ package body Sem_Res is 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. + -- 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); @@ -6464,19 +8254,17 @@ package body Sem_Res is ----------------------------- procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id) is - Conv_OK : constant Boolean := Conversion_OK (N); - Target_Type : Entity_Id := Etype (N); - Operand : Node_Id; - Opnd_Type : Entity_Id; + Conv_OK : constant Boolean := Conversion_OK (N); + Operand : constant Node_Id := Expression (N); + Operand_Typ : constant Entity_Id := Etype (Operand); + Target_Typ : constant Entity_Id := Etype (N); Rop : Node_Id; Orig_N : Node_Id; Orig_T : Node_Id; begin - Operand := Expression (N); - if not Conv_OK - and then not Valid_Conversion (N, Target_Type, Operand) + and then not Valid_Conversion (N, Target_Typ, Operand) then return; end if; @@ -6490,10 +8278,10 @@ package body Sem_Res is 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 Nkind_In (Operand, N_Op_Multiply, N_Op_Divide) and then (Etype (Right_Opnd (Operand)) = Universal_Real - or else Etype (Left_Opnd (Operand)) = Universal_Real) + or else + Etype (Left_Opnd (Operand)) = Universal_Real) then -- Return if expression is ambiguous @@ -6507,13 +8295,14 @@ package body Sem_Res is end if; -- Resolve the real operand with largest available precision + if Etype (Right_Opnd (Operand)) = Universal_Real then Rop := New_Copy_Tree (Right_Opnd (Operand)); else Rop := New_Copy_Tree (Left_Opnd (Operand)); end if; - Resolve (Rop, Standard_Long_Long_Float); + Resolve (Rop, Universal_Real); -- If the operand is a literal (it could be a non-static and -- illegal exponentiation) check whether the use of Duration @@ -6523,9 +8312,12 @@ package body Sem_Res is and then Realval (Rop) /= Ureal_0 and then abs (Realval (Rop)) < Delta_Value (Standard_Duration) then - Error_Msg_N ("universal real operand can only be interpreted?", - Rop); - Error_Msg_N ("\as Duration, and will lose precision?", Rop); + Error_Msg_N + ("?universal real operand can only " & + "be interpreted as Duration!", + Rop); + Error_Msg_N + ("\?precision will be lost in the conversion!", Rop); end if; elsif Is_Numeric_Type (Typ) @@ -6541,37 +8333,45 @@ package body Sem_Res is end if; end if; - Opnd_Type := Etype (Operand); Resolve (Operand); -- Note: we do the Eval_Type_Conversion call before applying the - -- required checks for a subtype conversion. This is important, - -- since both are prepared under certain circumstances to change - -- the type conversion to a constraint error node, but in the case - -- of Eval_Type_Conversion this may reflect an illegality in the - -- static case, and we would miss the illegality (getting only a - -- warning message), if we applied the type conversion checks first. + -- 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. + -- Even when evaluation is not possible, we may be able to simplify the + -- conversion or its expression. This needs to be done before applying + -- checks, since otherwise the checks may use the original expression + -- and defeat the simplifications. This is specifically the case for + -- elimination of the floating-point Truncation attribute in + -- float-to-int conversions. + + Simplify_Type_Conversion (N); + + -- If after evaluation we still have a type conversion, then we may need + -- to apply checks required for a subtype conversion. -- Skip these type conversion checks if universal fixed operands -- operands involved, since range checks are handled separately for -- these cases (in the appropriate Expand routines in unit Exp_Fixd). if Nkind (N) = N_Type_Conversion - and then not Is_Generic_Type (Root_Type (Target_Type)) - and then Target_Type /= Universal_Fixed - and then Opnd_Type /= Universal_Fixed + and then not Is_Generic_Type (Root_Type (Target_Typ)) + and then Target_Typ /= Universal_Fixed + and then Operand_Typ /= Universal_Fixed then Apply_Type_Conversion_Checks (N); end if; - -- Issue warning for conversion of simple object to its own type - -- We have to test the original nodes, since they may have been - -- rewritten by various optimizations. + -- Issue warning for conversion of simple object to its own type. We + -- have to test the original nodes, since they may have been rewritten + -- by various optimizations. Orig_N := Original_Node (N); @@ -6581,7 +8381,7 @@ package body Sem_Res is and then not In_Instance then Orig_N := Original_Node (Expression (Orig_N)); - Orig_T := Target_Type; + Orig_T := Target_Typ; -- If the node is part of a larger expression, the Target_Type -- may not be the original type of the node if the context is a @@ -6594,48 +8394,126 @@ package body Sem_Res is end if; if Is_Entity_Name (Orig_N) - and then Etype (Entity (Orig_N)) = Orig_T + and then + (Etype (Entity (Orig_N)) = Orig_T + or else + (Ekind (Entity (Orig_N)) = E_Loop_Parameter + and then Covers (Orig_T, Etype (Entity (Orig_N))))) then - Error_Msg_NE - ("?useless conversion, & has this type", N, Entity (Orig_N)); + -- One more check, do not give warning if the analyzed conversion + -- has an expression with non-static bounds, and the bounds of the + -- target are static. This avoids junk warnings in cases where the + -- conversion is necessary to establish staticness, for example in + -- a case statement. + + if not Is_OK_Static_Subtype (Operand_Typ) + and then Is_OK_Static_Subtype (Target_Typ) + then + null; + + -- Here we give the redundant conversion warning + + else + Error_Msg_Node_2 := Orig_T; + Error_Msg_NE -- CODEFIX + ("?redundant conversion, & is of type &!", + N, Entity (Orig_N)); + end if; end if; end if; - -- Ada 2005 (AI-251): Handle conversions to abstract interface types + -- Ada 2005 (AI-251): Handle class-wide interface type conversions. + -- No need to perform any interface conversion if the type of the + -- expression coincides with the target type. - if Ada_Version >= Ada_05 then - if Is_Access_Type (Target_Type) then - Target_Type := Directly_Designated_Type (Target_Type); - end if; + if Ada_Version >= Ada_05 + and then Expander_Active + and then Operand_Typ /= Target_Typ + then + declare + Opnd : Entity_Id := Operand_Typ; + Target : Entity_Id := Target_Typ; - if Is_Class_Wide_Type (Target_Type) then - Target_Type := Etype (Target_Type); - end if; + begin + if Is_Access_Type (Opnd) then + Opnd := Directly_Designated_Type (Opnd); + end if; - if Is_Interface (Target_Type) then - if Is_Class_Wide_Type (Opnd_Type) then - Opnd_Type := Etype (Opnd_Type); + if Is_Access_Type (Target_Typ) then + Target := Directly_Designated_Type (Target); end if; - if not Interface_Present_In_Ancestor - (Typ => Opnd_Type, - Iface => Target_Type) - then - if Nkind (Operand) = N_Attribute_Reference then - Error_Msg_Name_1 := Chars (Prefix (Operand)); + if Opnd = Target then + null; + + -- Conversion from interface type + + elsif Is_Interface (Opnd) then + + -- Ada 2005 (AI-217): Handle entities from limited views + + if From_With_Type (Opnd) then + Error_Msg_Qual_Level := 99; + Error_Msg_NE ("missing WITH clause on package &", N, + Cunit_Entity (Get_Source_Unit (Base_Type (Opnd)))); + Error_Msg_N + ("type conversions require visibility of the full view", + N); + + elsif From_With_Type (Target) + and then not + (Is_Access_Type (Target_Typ) + and then Present (Non_Limited_View (Etype (Target)))) + then + Error_Msg_Qual_Level := 99; + Error_Msg_NE ("missing WITH clause on package &", N, + Cunit_Entity (Get_Source_Unit (Base_Type (Target)))); + Error_Msg_N + ("type conversions require visibility of the full view", + N); + else - Error_Msg_Name_1 := Chars (Operand); + Expand_Interface_Conversion (N, Is_Static => False); end if; - Error_Msg_Name_2 := Chars (Target_Type); - Error_Msg_NE - ("(Ada 2005) % does not implement interface %", - Operand, Target_Type); + -- Conversion to interface type - else - Expand_Interface_Conversion (N); + elsif Is_Interface (Target) then + + -- Handle subtypes + + if Ekind (Opnd) = E_Protected_Subtype + or else Ekind (Opnd) = E_Task_Subtype + then + Opnd := Etype (Opnd); + end if; + + if not Interface_Present_In_Ancestor + (Typ => Opnd, + Iface => Target) + then + if Is_Class_Wide_Type (Opnd) then + + -- The static analysis is not enough to know if the + -- interface is implemented or not. Hence we must pass + -- the work to the expander to generate code to evaluate + -- the conversion at run-time. + + Expand_Interface_Conversion (N, Is_Static => False); + + else + Error_Msg_Name_1 := Chars (Etype (Target)); + Error_Msg_Name_2 := Chars (Opnd); + Error_Msg_N + ("wrong interface conversion (% is not a progenitor " & + "of %)", N); + end if; + + else + Expand_Interface_Conversion (N); + end if; end if; - end if; + end; end if; end Resolve_Type_Conversion; @@ -6651,6 +8529,29 @@ package body Sem_Res is Hi : Uint; begin + -- Deal with intrinsic unary operators + + if Comes_From_Source (N) + and then Ekind (Entity (N)) = E_Function + and then Is_Imported (Entity (N)) + and then Is_Intrinsic_Subprogram (Entity (N)) + then + Resolve_Intrinsic_Unary_Operator (N, Typ); + return; + end if; + + -- Deal with universal cases + + if Etype (R) = Universal_Integer + or else + Etype (R) = Universal_Real + then + Check_For_Visible_Operator (N, B_Typ); + end if; + + Set_Etype (N, B_Typ); + Resolve (R, B_Typ); + -- Generate warning for expressions like abs (x mod 2) if Warn_On_Redundant_Constructs @@ -6664,48 +8565,144 @@ package body Sem_Res is end if; end if; - -- Generate warning for expressions like -5 mod 3 + -- Deal with reference generation - if Paren_Count (N) = 0 - and then Nkind (N) = N_Op_Minus - and then Nkind (Right_Opnd (N)) = N_Op_Mod - and then Comes_From_Source (N) - then - Error_Msg_N - ("?unary minus expression should be parenthesized here", N); + Check_Unset_Reference (R); + Generate_Operator_Reference (N, B_Typ); + Eval_Unary_Op (N); + + -- Set overflow checking bit. Much cleverer code needed here eventually + -- and perhaps the Resolve routines should be separated for the various + -- arithmetic operations, since they will need different processing ??? + + if Nkind (N) in N_Op then + if not Overflow_Checks_Suppressed (Etype (N)) then + Enable_Overflow_Check (N); + end if; end if; - if Comes_From_Source (N) - and then Ekind (Entity (N)) = E_Function - and then Is_Imported (Entity (N)) - and then Is_Intrinsic_Subprogram (Entity (N)) - then - Resolve_Intrinsic_Unary_Operator (N, Typ); - return; - end if; + -- Generate warning for expressions like -5 mod 3 for integers. No need + -- to worry in the floating-point case, since parens do not affect the + -- result so there is no point in giving in a warning. + + declare + Norig : constant Node_Id := Original_Node (N); + Rorig : Node_Id; + Val : Uint; + HB : Uint; + LB : Uint; + Lval : Uint; + Opnd : Node_Id; + + begin + if Warn_On_Questionable_Missing_Parens + and then Comes_From_Source (Norig) + and then Is_Integer_Type (Typ) + and then Nkind (Norig) = N_Op_Minus + then + Rorig := Original_Node (Right_Opnd (Norig)); + + -- We are looking for cases where the right operand is not + -- parenthesized, and is a binary operator, multiply, divide, or + -- mod. These are the cases where the grouping can affect results. + + if Paren_Count (Rorig) = 0 + and then Nkind_In (Rorig, N_Op_Mod, N_Op_Multiply, N_Op_Divide) + then + -- For mod, we always give the warning, since the value is + -- affected by the parenthesization (e.g. (-5) mod 315 /= + -- -(5 mod 315)). But for the other cases, the only concern is + -- overflow, e.g. for the case of 8 big signed (-(2 * 64) + -- overflows, but (-2) * 64 does not). So we try to give the + -- message only when overflow is possible. + + if Nkind (Rorig) /= N_Op_Mod + and then Compile_Time_Known_Value (R) + then + Val := Expr_Value (R); + + if Compile_Time_Known_Value (Type_High_Bound (Typ)) then + HB := Expr_Value (Type_High_Bound (Typ)); + else + HB := Expr_Value (Type_High_Bound (Base_Type (Typ))); + end if; + + if Compile_Time_Known_Value (Type_Low_Bound (Typ)) then + LB := Expr_Value (Type_Low_Bound (Typ)); + else + LB := Expr_Value (Type_Low_Bound (Base_Type (Typ))); + end if; + + -- Note that the test below is deliberately excluding the + -- largest negative number, since that is a potentially + -- troublesome case (e.g. -2 * x, where the result is the + -- largest negative integer has an overflow with 2 * x). + + if Val > LB and then Val <= HB then + return; + end if; + end if; + + -- For the multiplication case, the only case we have to worry + -- about is when (-a)*b is exactly the largest negative number + -- so that -(a*b) can cause overflow. This can only happen if + -- a is a power of 2, and more generally if any operand is a + -- constant that is not a power of 2, then the parentheses + -- cannot affect whether overflow occurs. We only bother to + -- test the left most operand + + -- Loop looking at left operands for one that has known value + + Opnd := Rorig; + Opnd_Loop : while Nkind (Opnd) = N_Op_Multiply loop + if Compile_Time_Known_Value (Left_Opnd (Opnd)) then + Lval := UI_Abs (Expr_Value (Left_Opnd (Opnd))); + + -- Operand value of 0 or 1 skips warning + + if Lval <= 1 then + return; + + -- Otherwise check power of 2, if power of 2, warn, if + -- anything else, skip warning. + + else + while Lval /= 2 loop + if Lval mod 2 = 1 then + return; + else + Lval := Lval / 2; + end if; + end loop; + + exit Opnd_Loop; + end if; + end if; + + -- Keep looking at left operands - if Etype (R) = Universal_Integer - or else Etype (R) = Universal_Real - then - Check_For_Visible_Operator (N, B_Typ); - end if; + Opnd := Left_Opnd (Opnd); + end loop Opnd_Loop; - Set_Etype (N, B_Typ); - Resolve (R, B_Typ); + -- For rem or "/" we can only have a problematic situation + -- if the divisor has a value of minus one or one. Otherwise + -- overflow is impossible (divisor > 1) or we have a case of + -- division by zero in any case. - Check_Unset_Reference (R); - Generate_Operator_Reference (N, B_Typ); - Eval_Unary_Op (N); + if Nkind_In (Rorig, N_Op_Divide, N_Op_Rem) + and then Compile_Time_Known_Value (Right_Opnd (Rorig)) + and then UI_Abs (Expr_Value (Right_Opnd (Rorig))) /= 1 + then + return; + end if; - -- 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 we fall through warning should be issued - if Nkind (N) in N_Op then - if not Overflow_Checks_Suppressed (Etype (N)) then - Enable_Overflow_Check (N); + Error_Msg_N + ("?unary minus expression should be parenthesized here!", N); + end if; end if; - end if; + end; end Resolve_Unary_Op; ---------------------------------- @@ -6783,9 +8780,9 @@ package body Sem_Res is Op_Node : Node_Id; begin - -- Rewrite the operator node using the real operator, not its - -- renaming. Exclude user-defined intrinsic operations of the same - -- name, which are treated separately and rewritten as calls. + -- Rewrite the operator node using the real operator, not its renaming. + -- Exclude user-defined intrinsic operations of the same name, which are + -- treated separately and rewritten as calls. if Ekind (Op) /= E_Function or else Chars (N) /= Nam @@ -6796,8 +8793,8 @@ package body Sem_Res is Set_Entity (Op_Node, Op); Set_Right_Opnd (Op_Node, Right_Opnd (N)); - -- Indicate that both the original entity and its renaming - -- are referenced at this point. + -- Indicate that both the original entity and its renaming are + -- referenced at this point. Generate_Reference (Entity (N), N); Generate_Reference (Op, N); @@ -6820,7 +8817,7 @@ package body Sem_Res is N_Op_Expon | N_Op_Mod | N_Op_Rem => Resolve_Intrinsic_Operator (N, Typ); - when N_Op_Plus | N_Op_Minus | N_Op_Abs => + when N_Op_Plus | N_Op_Minus | N_Op_Abs => Resolve_Intrinsic_Unary_Operator (N, Typ); when others => @@ -6832,7 +8829,7 @@ package body Sem_Res is and then Is_Intrinsic_Subprogram (Op) then -- Operator renames a user-defined operator of the same name. Use - -- the original operator in the node, which is the one that gigi + -- the original operator in the node, which is the one that Gigi -- knows about. Set_Entity (N, Op); @@ -6846,7 +8843,7 @@ package body Sem_Res is -- 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 + -- 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. @@ -6895,12 +8892,11 @@ package body Sem_Res is 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. + -- 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); @@ -6910,7 +8906,9 @@ package body Sem_Res is -- 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 + -- Why the test for In_Spec_Expression here ??? + + if Is_Packed (Slice_Subtype) and not In_Spec_Expression then Freeze_Itype (Slice_Subtype, N); end if; @@ -6921,31 +8919,132 @@ package body Sem_Res is -------------------------------- procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + Low_Bound : constant Node_Id := + Type_Low_Bound (Etype (First_Index (Typ))); Subtype_Id : Entity_Id; begin if Nkind (N) /= N_String_Literal then return; - else - Subtype_Id := Create_Itype (E_String_Literal_Subtype, N); end if; + Subtype_Id := Create_Itype (E_String_Literal_Subtype, N); Set_String_Literal_Length (Subtype_Id, UI_From_Int (String_Length (Strval (N)))); - Set_Etype (Subtype_Id, Base_Type (Typ)); - Set_Is_Constrained (Subtype_Id); + Set_Etype (Subtype_Id, Base_Type (Typ)); + Set_Is_Constrained (Subtype_Id); + Set_Etype (N, Subtype_Id); + + if Is_OK_Static_Expression (Low_Bound) then -- The low bound is set from the low bound of the corresponding -- index type. Note that we do not store the high bound in the - -- string literal subtype, but it can be deduced if necssary + -- string literal subtype, but it can be deduced if necessary -- from the length and the low bound. - Set_String_Literal_Low_Bound - (Subtype_Id, Type_Low_Bound (Etype (First_Index (Typ)))); + Set_String_Literal_Low_Bound (Subtype_Id, Low_Bound); + + else + Set_String_Literal_Low_Bound + (Subtype_Id, Make_Integer_Literal (Loc, 1)); + Set_Etype (String_Literal_Low_Bound (Subtype_Id), Standard_Positive); + + -- Build bona fide subtype for the string, and wrap it in an + -- unchecked conversion, because the backend expects the + -- String_Literal_Subtype to have a static lower bound. + + declare + Index_List : constant List_Id := New_List; + Index_Type : constant Entity_Id := Etype (First_Index (Typ)); + High_Bound : constant Node_Id := + Make_Op_Add (Loc, + Left_Opnd => New_Copy_Tree (Low_Bound), + Right_Opnd => + Make_Integer_Literal (Loc, + String_Length (Strval (N)) - 1)); + Array_Subtype : Entity_Id; + Index_Subtype : Entity_Id; + Drange : Node_Id; + Index : Node_Id; + + begin + Index_Subtype := + Create_Itype (Subtype_Kind (Ekind (Index_Type)), N); + Drange := Make_Range (Loc, New_Copy_Tree (Low_Bound), High_Bound); + Set_Scalar_Range (Index_Subtype, Drange); + Set_Parent (Drange, N); + Analyze_And_Resolve (Drange, Index_Type); + + -- In the context, the Index_Type may already have a constraint, + -- so use common base type on string subtype. The base type may + -- be used when generating attributes of the string, for example + -- in the context of a slice assignment. + + Set_Etype (Index_Subtype, Base_Type (Index_Type)); + Set_Size_Info (Index_Subtype, Index_Type); + Set_RM_Size (Index_Subtype, RM_Size (Index_Type)); - Set_Etype (N, Subtype_Id); + Array_Subtype := Create_Itype (E_Array_Subtype, N); + + Index := New_Occurrence_Of (Index_Subtype, Loc); + Set_Etype (Index, Index_Subtype); + Append (Index, Index_List); + + Set_First_Index (Array_Subtype, Index); + Set_Etype (Array_Subtype, Base_Type (Typ)); + Set_Is_Constrained (Array_Subtype, True); + + Rewrite (N, + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Array_Subtype, Loc), + Expression => Relocate_Node (N))); + Set_Etype (N, Array_Subtype); + end; + end if; end Set_String_Literal_Subtype; + ------------------------------ + -- Simplify_Type_Conversion -- + ------------------------------ + + procedure Simplify_Type_Conversion (N : Node_Id) is + begin + if Nkind (N) = N_Type_Conversion then + declare + Operand : constant Node_Id := Expression (N); + Target_Typ : constant Entity_Id := Etype (N); + Opnd_Typ : constant Entity_Id := Etype (Operand); + + begin + if Is_Floating_Point_Type (Opnd_Typ) + and then + (Is_Integer_Type (Target_Typ) + or else (Is_Fixed_Point_Type (Target_Typ) + and then Conversion_OK (N))) + and then Nkind (Operand) = N_Attribute_Reference + and then Attribute_Name (Operand) = Name_Truncation + + -- Special processing required if the conversion is the expression + -- of a Truncation attribute reference. In this case we replace: + + -- ityp (ftyp'Truncation (x)) + + -- by + + -- ityp (x) + + -- with the Float_Truncate flag set, which is more efficient + + then + Rewrite (Operand, + Relocate_Node (First (Expressions (Operand)))); + Set_Float_Truncate (N, True); + end if; + end; + end if; + end Simplify_Type_Conversion; + ----------------------------- -- Unique_Fixed_Point_Type -- ----------------------------- @@ -6957,7 +9056,8 @@ package body Sem_Res is Scop : Entity_Id; procedure Fixed_Point_Error; - -- If true ambiguity, give details + -- Give error messages for true ambiguity. Messages are posted on node + -- N, and entities T1, T2 are the possible interpretations. ----------------------- -- Fixed_Point_Error -- @@ -6966,8 +9066,8 @@ package body Sem_Res is 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); + Error_Msg_NE ("\\possible interpretation as}", N, T1); + Error_Msg_NE ("\\possible interpretation as}", N, T2); end Fixed_Point_Error; -- Start of processing for Unique_Fixed_Point_Type @@ -6983,7 +9083,6 @@ package body Sem_Res is Scop := Current_Scope; while Scop /= Standard_Standard loop T2 := First_Entity (Scop); - while Present (T2) loop if Is_Fixed_Point_Type (T2) and then Current_Entity (T2) = T2 @@ -7010,7 +9109,6 @@ package body Sem_Res is 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 @@ -7033,10 +9131,9 @@ package body Sem_Res is end loop; if Nkind (N) = N_Real_Literal then - Error_Msg_NE ("real literal interpreted as }?", N, T1); - + Error_Msg_NE ("?real literal interpreted as }!", N, T1); else - Error_Msg_NE ("universal_fixed expression interpreted as }?", N, T1); + Error_Msg_NE ("?universal_fixed expression interpreted as }!", N, T1); end if; return T1; @@ -7064,6 +9161,10 @@ package body Sem_Res is Opnd_Type : Entity_Id) return Boolean; -- Specifically test for validity of tagged conversions + function Valid_Array_Conversion return Boolean; + -- Check index and component conformance, and accessibility levels + -- if the component types are anonymous access types (Ada 2005) + ---------------------- -- Conversion_Check -- ---------------------- @@ -7080,6 +9181,136 @@ package body Sem_Res is return Valid; end Conversion_Check; + ---------------------------- + -- Valid_Array_Conversion -- + ---------------------------- + + function Valid_Array_Conversion return Boolean + is + Opnd_Comp_Type : constant Entity_Id := Component_Type (Opnd_Type); + Opnd_Comp_Base : constant Entity_Id := Base_Type (Opnd_Comp_Type); + + Opnd_Index : Node_Id; + Opnd_Index_Type : Entity_Id; + + Target_Comp_Type : constant Entity_Id := + Component_Type (Target_Type); + Target_Comp_Base : constant Entity_Id := + Base_Type (Target_Comp_Type); + + Target_Index : Node_Id; + Target_Index_Type : Entity_Id; + + begin + -- Error if wrong number of dimensions + + if + Number_Dimensions (Target_Type) /= Number_Dimensions (Opnd_Type) + then + Error_Msg_N + ("incompatible number of dimensions for conversion", Operand); + return False; + + -- Number of dimensions matches + + else + -- Loop through indexes of the two arrays + + Target_Index := First_Index (Target_Type); + Opnd_Index := First_Index (Opnd_Type); + while Present (Target_Index) and then Present (Opnd_Index) loop + Target_Index_Type := Etype (Target_Index); + Opnd_Index_Type := Etype (Opnd_Index); + + -- Error if index types are incompatible + + if not (Is_Integer_Type (Target_Index_Type) + and then Is_Integer_Type (Opnd_Index_Type)) + and then (Root_Type (Target_Index_Type) + /= Root_Type (Opnd_Index_Type)) + then + Error_Msg_N + ("incompatible index types for array conversion", + Operand); + return False; + end if; + + Next_Index (Target_Index); + Next_Index (Opnd_Index); + end loop; + + -- If component types have same base type, all set + + if Target_Comp_Base = Opnd_Comp_Base then + null; + + -- Here if base types of components are not the same. The only + -- time this is allowed is if we have anonymous access types. + + -- The conversion of arrays of anonymous access types can lead + -- to dangling pointers. AI-392 formalizes the accessibility + -- checks that must be applied to such conversions to prevent + -- out-of-scope references. + + elsif + (Ekind (Target_Comp_Base) = E_Anonymous_Access_Type + or else + Ekind (Target_Comp_Base) = E_Anonymous_Access_Subprogram_Type) + and then Ekind (Opnd_Comp_Base) = Ekind (Target_Comp_Base) + and then + Subtypes_Statically_Match (Target_Comp_Type, Opnd_Comp_Type) + then + if Type_Access_Level (Target_Type) < + Type_Access_Level (Opnd_Type) + then + if In_Instance_Body then + Error_Msg_N ("?source array type " & + "has deeper accessibility level than target", Operand); + Error_Msg_N ("\?Program_Error will be raised at run time", + Operand); + Rewrite (N, + Make_Raise_Program_Error (Sloc (N), + Reason => PE_Accessibility_Check_Failed)); + Set_Etype (N, Target_Type); + return False; + + -- Conversion not allowed because of accessibility levels + + else + Error_Msg_N ("source array type " & + "has deeper accessibility level than target", Operand); + return False; + end if; + else + null; + end if; + + -- All other cases where component base types do not match + + else + Error_Msg_N + ("incompatible component types for array conversion", + Operand); + return False; + end if; + + -- Check that component subtypes statically match. For numeric + -- types this means that both must be either constrained or + -- unconstrained. For enumeration types the bounds must match. + -- All of this is checked in Subtypes_Statically_Match. + + if not Subtypes_Statically_Match + (Target_Comp_Type, Opnd_Comp_Type) + then + Error_Msg_N + ("component subtypes must statically match", Operand); + return False; + end if; + end if; + + return True; + end Valid_Array_Conversion; + ----------------------------- -- Valid_Tagged_Conversion -- ----------------------------- @@ -7100,7 +9331,7 @@ package body Sem_Res is -- (RM 4.6(23)). elsif Is_Class_Wide_Type (Opnd_Type) - and then Covers (Opnd_Type, Target_Type) + and then Covers (Opnd_Type, Target_Type) then return True; @@ -7111,10 +9342,26 @@ package body Sem_Res is Conversion_Check (False, "downward conversion of tagged objects not allowed"); - -- Ada 2005 (AI-251): The conversion of a tagged type to an - -- abstract interface type is always valid + -- Ada 2005 (AI-251): The conversion to/from interface types is + -- always valid - elsif Is_Interface (Target_Type) then + elsif Is_Interface (Target_Type) or else Is_Interface (Opnd_Type) then + return True; + + -- If the operand is a class-wide type obtained through a limited_ + -- with clause, and the context includes the non-limited view, use + -- it to determine whether the conversion is legal. + + elsif Is_Class_Wide_Type (Opnd_Type) + and then From_With_Type (Opnd_Type) + and then Present (Non_Limited_View (Etype (Opnd_Type))) + and then Is_Interface (Non_Limited_View (Etype (Opnd_Type))) + then + return True; + + elsif Is_Access_Type (Opnd_Type) + and then Is_Interface (Directly_Designated_Type (Opnd_Type)) + then return True; else @@ -7139,20 +9386,46 @@ package body Sem_Res is N1 : Entity_Id; begin - -- Remove procedure calls, which syntactically cannot appear - -- in this context, but which cannot be removed by type checking, + -- Remove procedure calls, which syntactically cannot appear in + -- this context, but which cannot be removed by type checking, -- because the context does not impose a type. + -- When compiling for VMS, spurious ambiguities can be produced + -- when arithmetic operations have a literal operand and return + -- System.Address or a descendant of it. These ambiguities are + -- otherwise resolved by the context, but for conversions there + -- is no context type and the removal of the spurious operations + -- must be done explicitly here. + + -- The node may be labelled overloaded, but still contain only + -- one interpretation because others were discarded in previous + -- filters. If this is the case, retain the single interpretation + -- if legal. + Get_First_Interp (Operand, I, It); + Opnd_Type := It.Typ; + Get_Next_Interp (I, It); - while Present (It.Typ) loop + if Present (It.Typ) + and then Opnd_Type /= Standard_Void_Type + then + -- More than one candidate interpretation is available - if It.Typ = Standard_Void_Type then - Remove_Interp (I); - end if; + 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; + if Present (System_Aux_Id) + and then Is_Descendent_Of_Address (It.Typ) + then + Remove_Interp (I); + end if; + + Get_Next_Interp (I, It); + end loop; + end if; Get_First_Interp (Operand, I, It); I1 := I; @@ -7173,10 +9446,12 @@ package body Sem_Res is Error_Msg_N ("ambiguous operand in conversion", Operand); Error_Msg_Sloc := Sloc (It.Nam); - Error_Msg_N ("possible interpretation#!", Operand); + Error_Msg_N -- CODEFIX + ("\\possible interpretation#!", Operand); Error_Msg_Sloc := Sloc (N1); - Error_Msg_N ("possible interpretation#!", Operand); + Error_Msg_N -- CODEFIX + ("\\possible interpretation#!", Operand); return False; end if; @@ -7187,27 +9462,40 @@ package body Sem_Res is end; end if; - if Chars (Current_Scope) = Name_Unchecked_Conversion then + -- Numeric types - -- This check is dubious, what if there were a user defined - -- scope whose name was Unchecked_Conversion ??? + if Is_Numeric_Type (Target_Type) then - return True; + -- A universal fixed expression can be converted to any numeric type - elsif Is_Numeric_Type (Target_Type) then if Opnd_Type = Universal_Fixed then return True; - elsif (In_Instance or else In_Inlined_Body) - and then not Comes_From_Source (N) - then - return True; + -- Also no need to check when in an instance or inlined body, because + -- the legality has been established when the template was analyzed. + -- Furthermore, numeric conversions may occur where only a private + -- view of the operand type is visible at the instantiation point. + -- This results in a spurious error if we check that the operand type + -- is a numeric type. + + -- Note: in a previous version of this unit, the following tests were + -- applied only for generated code (Comes_From_Source set to False), + -- but in fact the test is required for source code as well, since + -- this situation can arise in source code. + + elsif In_Instance or else In_Inlined_Body then + return True; + + -- Otherwise we need the conversion check else - return Conversion_Check (Is_Numeric_Type (Opnd_Type), - "illegal operand for numeric conversion"); + return Conversion_Check + (Is_Numeric_Type (Opnd_Type), + "illegal operand for numeric conversion"); end if; + -- Array types + elsif Is_Array_Type (Target_Type) then if not Is_Array_Type (Opnd_Type) or else Opnd_Type = Any_Composite @@ -7216,80 +9504,21 @@ package body Sem_Res is 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 : constant Entity_Id := - Component_Type (Target_Type); - Opnd_Comp_Type : constant 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; + return Valid_Array_Conversion; end if; - return True; - - -- Ada 2005 (AI-251) + -- Ada 2005 (AI-251): Anonymous access types where target references an + -- interface type. elsif (Ekind (Target_Type) = E_General_Access_Type - or else Ekind (Target_Type) = E_Anonymous_Access_Type) + or else + Ekind (Target_Type) = E_Anonymous_Access_Type) and then Is_Interface (Directly_Designated_Type (Target_Type)) then -- Check the static accessibility rule of 4.6(17). Note that the - -- check is not enforced when within an instance body, since the RM - -- requires such cases to be caught at run time. + -- 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) > @@ -7304,8 +9533,7 @@ package body Sem_Res is ("?cannot convert local pointer to non-local access type", Operand); Error_Msg_N - ("?Program_Error will be raised at run time", Operand); - + ("\?Program_Error will be raised at run time", Operand); else Error_Msg_N ("cannot convert local pointer to non-local access type", @@ -7321,24 +9549,23 @@ package body Sem_Res is 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.) + -- 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) + 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. + -- 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); - + ("\?Program_Error will be raised at run time", Operand); else Error_Msg_N ("cannot convert access discriminant to non-local" & @@ -7350,7 +9577,7 @@ package body Sem_Res is -- The case of a reference to an access discriminant from -- within a limited type declaration (which will appear as -- a discriminal) is always illegal because the level of the - -- discriminant is considered to be deeper than any (namable) + -- discriminant is considered to be deeper than any (nameable) -- access type. if Is_Entity_Name (Operand) @@ -7369,6 +9596,8 @@ package body Sem_Res is return True; + -- General and anonymous access types + elsif (Ekind (Target_Type) = E_General_Access_Type or else Ekind (Target_Type) = E_Anonymous_Access_Type) and then @@ -7398,21 +9627,26 @@ package body Sem_Res is 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. + -- 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); + ("\?Program_Error will be raised at run time", Operand); else - Error_Msg_N - ("cannot convert local pointer to non-local access type", - Operand); + -- Avoid generation of spurious error message + + if not Error_Posted (N) then + Error_Msg_N + ("cannot convert local pointer to non-local access type", + Operand); + end if; + return False; end if; @@ -7425,23 +9659,24 @@ package body Sem_Res is -- 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.) + -- 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) + 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. + -- 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); + ("\?Program_Error will be raised at run time", + Operand); else Error_Msg_N @@ -7454,7 +9689,7 @@ package body Sem_Res is -- The case of a reference to an access discriminant from -- within a limited type declaration (which will appear as -- a discriminal) is always illegal because the level of the - -- discriminant is considered to be deeper than any (namable) + -- discriminant is considered to be deeper than any (nameable) -- access type. if Is_Entity_Name (Operand) @@ -7470,16 +9705,49 @@ package body Sem_Res is end if; end if; - declare - Target : constant Entity_Id := Designated_Type (Target_Type); - Opnd : constant Entity_Id := Designated_Type (Opnd_Type); + -- In the presence of limited_with clauses we have to use non-limited + -- views, if available. + + Check_Limited : declare + function Full_Designated_Type (T : Entity_Id) return Entity_Id; + -- Helper function to handle limited views + + -------------------------- + -- Full_Designated_Type -- + -------------------------- + + function Full_Designated_Type (T : Entity_Id) return Entity_Id is + Desig : constant Entity_Id := Designated_Type (T); + + begin + -- Handle the limited view of a type + + if Is_Incomplete_Type (Desig) + and then From_With_Type (Desig) + and then Present (Non_Limited_View (Desig)) + then + return Available_View (Desig); + else + return Desig; + end if; + end Full_Designated_Type; + + -- Local Declarations + + Target : constant Entity_Id := Full_Designated_Type (Target_Type); + Opnd : constant Entity_Id := Full_Designated_Type (Opnd_Type); + + Same_Base : constant Boolean := + Base_Type (Target) = Base_Type (Opnd); + + -- Start of processing for Check_Limited begin if Is_Tagged_Type (Target) then return Valid_Tagged_Conversion (Target, Opnd); else - if Base_Type (Target) /= Base_Type (Opnd) then + if not Same_Base then Error_Msg_NE ("target designated type not compatible with }", N, Base_Type (Opnd)); @@ -7497,7 +9765,27 @@ package body Sem_Res is (not Is_Constrained (Opnd) or else not Is_Constrained (Target))) then - return True; + -- Special case, if Value_Size has been used to make the + -- sizes different, the conversion is not allowed even + -- though the subtypes statically match. + + if Known_Static_RM_Size (Target) + and then Known_Static_RM_Size (Opnd) + and then RM_Size (Target) /= RM_Size (Opnd) + then + Error_Msg_NE + ("target designated subtype not compatible with }", + N, Opnd); + Error_Msg_NE + ("\because sizes of the two designated subtypes differ", + N, Opnd); + return False; + + -- Normal case where conversion is allowed + + else + return True; + end if; else Error_Msg_NE @@ -7506,16 +9794,39 @@ package body Sem_Res is return False; end if; end if; - end; + end Check_Limited; - elsif (Ekind (Target_Type) = E_Access_Subprogram_Type - or else - Ekind (Target_Type) = E_Anonymous_Access_Subprogram_Type) + -- Access to subprogram types. If the operand is an access parameter, + -- the type has a deeper accessibility that any master, and cannot + -- be assigned. We must make an exception if the conversion is part + -- of an assignment and the target is the return object of an extended + -- return statement, because in that case the accessibility check + -- takes place after the return. + + elsif Is_Access_Subprogram_Type (Target_Type) and then No (Corresponding_Remote_Type (Opnd_Type)) - and then Conversion_Check - (Ekind (Base_Type (Opnd_Type)) = E_Access_Subprogram_Type, - "illegal operand for access subprogram conversion") then + if Ekind (Base_Type (Opnd_Type)) = E_Anonymous_Access_Subprogram_Type + and then Is_Entity_Name (Operand) + and then Ekind (Entity (Operand)) = E_In_Parameter + and then + (Nkind (Parent (N)) /= N_Assignment_Statement + or else not Is_Entity_Name (Name (Parent (N))) + or else not Is_Return_Object (Entity (Name (Parent (N))))) + then + Error_Msg_N + ("illegal attempt to store anonymous access to subprogram", + Operand); + Error_Msg_N + ("\value has deeper accessibility than any master " & + "(RM 3.10.2 (13))", + Operand); + + Error_Msg_NE + ("\use named access type for& instead of access parameter", + Operand, Entity (Operand)); + end if; + -- Check that the designated types are subtype conformant Check_Subtype_Conformant (New_Id => Designated_Type (Target_Type), @@ -7540,10 +9851,10 @@ package body Sem_Res is O_Gen : constant Node_Id := Enclosing_Generic_Body (Opnd_Type); - T_Gen : Node_Id := - Enclosing_Generic_Body (Target_Type); + T_Gen : Node_Id; begin + T_Gen := Enclosing_Generic_Body (Target_Type); while Present (T_Gen) and then T_Gen /= O_Gen loop T_Gen := Enclosing_Generic_Body (T_Gen); end loop; @@ -7558,6 +9869,8 @@ package body Sem_Res is return True; + -- Remote subprogram access types + elsif Is_Remote_Access_To_Subprogram_Type (Target_Type) and then Is_Remote_Access_To_Subprogram_Type (Opnd_Type) then @@ -7573,7 +9886,11 @@ package body Sem_Res is N); return True; - elsif Is_Tagged_Type (Target_Type) then + -- If both are tagged types, check legality of view conversions + + elsif Is_Tagged_Type (Target_Type) + and then Is_Tagged_Type (Opnd_Type) + then return Valid_Tagged_Conversion (Target_Type, Opnd_Type); -- Types derived from the same root type are convertible @@ -7581,11 +9898,13 @@ package body Sem_Res is 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. + -- In an instance or an inlined body, there may be inconsistent + -- views of the same type, or of types derived from a common root. - elsif In_Instance - and then Underlying_Type (Target_Type) = Underlying_Type (Opnd_Type) + elsif (In_Instance or In_Inlined_Body) + and then + Root_Type (Underlying_Type (Target_Type)) = + Root_Type (Underlying_Type (Opnd_Type)) then return True; @@ -7596,13 +9915,11 @@ package body Sem_Res is 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;