X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fsem_res.adb;h=e1e9b7b4ec3f89f5ab9d51159aec7df06d0228b9;hb=5f8ee4c98bd8abddb3639ede9b66ab9b8825c020;hp=ef4ca9e346c25d7e4159fedf4af093b5d69a0315;hpb=ba8e3813e51a554dc56169ba8316152b02cecb76;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index ef4ca9e346c..e1e9b7b4ec3 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6,9 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision$ --- -- --- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 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- -- @@ -18,11 +16,11 @@ -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- --- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ @@ -33,7 +31,9 @@ with Debug_A; use Debug_A; with Einfo; use Einfo; with Errout; use Errout; with Expander; use Expander; +with Exp_Disp; use Exp_Disp; with Exp_Ch7; use Exp_Ch7; +with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Freeze; use Freeze; with Itypes; use Itypes; @@ -45,6 +45,7 @@ with Nlists; use Nlists; with Opt; use Opt; with Output; use Output; with Restrict; use Restrict; +with Rident; use Rident; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Aggr; use Sem_Aggr; @@ -62,6 +63,7 @@ with Sem_Util; use Sem_Util; with Sem_Type; use Sem_Type; with Sem_Warn; use Sem_Warn; with Sinfo; use Sinfo; +with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; with Targparm; use Targparm; @@ -88,6 +90,11 @@ package body Sem_Res is -- 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). @@ -107,8 +114,8 @@ package body Sem_Res is procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id); -- If the type of the object being initialized uses the secondary stack -- directly or indirectly, create a transient scope for the call to the - -- Init_Proc. This is because we do not create transient scopes for the - -- initialization of individual components within the init_proc itself. + -- init proc. This is because we do not create transient scopes for the + -- initialization of individual components within the init proc itself. -- Could be optimized away perhaps? function Is_Predefined_Op (Nam : Entity_Id) return Boolean; @@ -157,13 +164,14 @@ package body Sem_Res is function Operator_Kind (Op_Name : Name_Id; - Is_Binary : Boolean) - return Node_Kind; + Is_Binary : Boolean) return Node_Kind; -- Utility to map the name of an operator into the corresponding Node. Used -- by other node rewriting procedures. procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id); -- Resolve actuals of call, and add default expressions for missing ones. + -- N is the Node_Id for the subprogram call, and Nam is the entity of the + -- called subprogram. procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id); -- Called from Resolve_Call, when the prefix denotes an entry or element @@ -176,6 +184,9 @@ package body Sem_Res is -- A call to a user-defined intrinsic operator is rewritten as a call -- to the corresponding predefined operator, with suitable conversions. + procedure Resolve_Intrinsic_Unary_Operator (N : Node_Id; Typ : Entity_Id); + -- Ditto, for unary operators (only arithmetic ones) + procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id); -- If an operator node resolves to a call to a user-defined operator, -- rewrite the node as a function call. @@ -189,29 +200,31 @@ package body Sem_Res is -- that operands are resolved properly. Recall that predefined operators -- do not have a full signature and special resolution rules apply. - procedure Rewrite_Renamed_Operator (N : Node_Id; Op : Entity_Id); + procedure Rewrite_Renamed_Operator + (N : Node_Id; + Op : Entity_Id; + Typ : Entity_Id); -- An operator can rename another, e.g. in an instantiation. In that - -- case, the proper operator node must be constructed. + -- case, the proper operator node must be constructed and resolved. procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id); -- The String_Literal_Subtype is built for all strings that are not - -- operands of a static concatenation operation. If the argument is not - -- a String the function is a no-op. + -- operands of a static concatenation operation. If the argument is + -- not a N_String_Literal node, then the call has no effect. procedure Set_Slice_Subtype (N : Node_Id); - -- Build subtype of array type, with the range specified by the slice. + -- Build subtype of array type, with the range specified by the slice function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id; - -- A universal_fixed expression in an universal context is unambiguous if - -- there is only one applicable fixed point type. Determining whether + -- A universal_fixed expression in an universal context is unambiguous + -- if there is only one applicable fixed point type. Determining whether -- there is only one requires a search over all visible entities, and -- happens only in very pathological cases (see 6115-006). function Valid_Conversion (N : Node_Id; Target : Entity_Id; - Operand : Node_Id) - return Boolean; + Operand : Node_Id) return Boolean; -- Verify legality rules given in 4.6 (8-23). Target is the target -- type of the conversion, which may be an implicit conversion of -- an actual parameter to an anonymous access type (in which case @@ -231,14 +244,10 @@ package body Sem_Res is ("\possible interpretations: Character, Wide_Character!", C); E := Current_Entity (C); - - if Present (E) then - - while Present (E) loop - Error_Msg_NE ("\possible interpretation:}!", C, Etype (E)); - E := Homonym (E); - end loop; - end if; + while Present (E) loop + Error_Msg_NE ("\possible interpretation:}!", C, Etype (E)); + E := Homonym (E); + end loop; end if; end Ambiguous_Character; @@ -249,7 +258,7 @@ package body Sem_Res is procedure Analyze_And_Resolve (N : Node_Id) is begin Analyze (N); - Resolve (N, Etype (N)); + Resolve (N); end Analyze_And_Resolve; procedure Analyze_And_Resolve (N : Node_Id; Typ : Entity_Id) is @@ -265,12 +274,12 @@ package body Sem_Res is Typ : Entity_Id; Suppress : Check_Id) is - Scop : Entity_Id := Current_Scope; + Scop : constant Entity_Id := Current_Scope; begin if Suppress = All_Checks then declare - Svg : constant Suppress_Record := Scope_Suppress; + Svg : constant Suppress_Array := Scope_Suppress; begin Scope_Suppress := (others => True); @@ -280,12 +289,12 @@ package body Sem_Res is else declare - Svg : constant Boolean := Get_Scope_Suppress (Suppress); + Svg : constant Boolean := Scope_Suppress (Suppress); begin - Set_Scope_Suppress (Suppress, True); + Scope_Suppress (Suppress) := True; Analyze_And_Resolve (N, Typ); - Set_Scope_Suppress (Suppress, Svg); + Scope_Suppress (Suppress) := Svg; end; end if; @@ -307,12 +316,12 @@ package body Sem_Res is (N : Node_Id; Suppress : Check_Id) is - Scop : Entity_Id := Current_Scope; + Scop : constant Entity_Id := Current_Scope; begin if Suppress = All_Checks then declare - Svg : constant Suppress_Record := Scope_Suppress; + Svg : constant Suppress_Array := Scope_Suppress; begin Scope_Suppress := (others => True); @@ -322,12 +331,12 @@ package body Sem_Res is else declare - Svg : constant Boolean := Get_Scope_Suppress (Suppress); + Svg : constant Boolean := Scope_Suppress (Suppress); begin - Set_Scope_Suppress (Suppress, True); + Scope_Suppress (Suppress) := True; Analyze_And_Resolve (N); - Set_Scope_Suppress (Suppress, Svg); + Scope_Suppress (Suppress) := Svg; end; end if; @@ -339,6 +348,19 @@ 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 -- ---------------------------- @@ -350,20 +372,20 @@ package body Sem_Res is D : Node_Id; begin - -- Any use in a default expression is legal. + -- Any use in a default expression is legal if In_Default_Expression then null; elsif Nkind (PN) = N_Range then - -- Discriminant cannot be used to constrain a scalar type. + -- Discriminant cannot be used to constrain a scalar type P := Parent (PN); if Nkind (P) = N_Range_Constraint and then Nkind (Parent (P)) = N_Subtype_Indication - and then Nkind (Parent (Parent (P))) = N_Component_Declaration + and then Nkind (Parent (Parent (P))) = N_Component_Definition then Error_Msg_N ("discriminant cannot constrain scalar type", N); @@ -389,9 +411,10 @@ 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_Declaration - or else Nkind (Parent (Parent (P))) = N_Subtype_Declaration) + and then + (Nkind (Parent (Parent (P))) = N_Component_Definition + or else + Nkind (Parent (Parent (P))) = N_Subtype_Declaration) and then Paren_Count (N) = 0) then Error_Msg_N @@ -400,8 +423,9 @@ package body Sem_Res is end if; -- Detect a common beginner error: + -- type R (D : Positive := 100) is record - -- Name: String (1 .. D); + -- Name : String (1 .. D); -- end record; -- The default value causes an object of type R to be @@ -418,6 +442,10 @@ package body Sem_Res is -- any array whose index type covered the whole range of -- the type would likely raise Storage_Error. + ------------------------ + -- Large_Storage_Type -- + ------------------------ + function Large_Storage_Type (T : Entity_Id) return Boolean is begin return @@ -492,8 +520,8 @@ package body Sem_Res is -- Warn about the danger Error_Msg_N - ("creation of object of this type may raise Storage_Error?", - N); + ("creation of & object may raise Storage_Error?", + Scope (Disc)); <> null; @@ -509,6 +537,12 @@ package body Sem_Res is if Paren_Count (N) > 0 then Error_Msg_N ("discriminant in constraint must appear alone", N); + + elsif Nkind (N) = N_Expanded_Name + and then Comes_From_Source (N) + then + Error_Msg_N + ("discriminant must appear alone as a direct name", N); end if; return; @@ -519,7 +553,6 @@ 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 @@ -536,16 +569,17 @@ package body Sem_Res is if (Nkind (P) = N_Subtype_Indication and then - (Nkind (Parent (P)) = N_Component_Declaration - or else Nkind (Parent (P)) = N_Derived_Type_Definition) + (Nkind (Parent (P)) = N_Component_Definition + or else + Nkind (Parent (P)) = N_Derived_Type_Definition) and then D = Constraint (P)) -- The constraint itself may be given by a subtype indication, -- rather than by a more common discrete range. or else (Nkind (P) = N_Subtype_Indication - and then Nkind (Parent (P)) = N_Index_Or_Discriminant_Constraint) - + and then + Nkind (Parent (P)) = N_Index_Or_Discriminant_Constraint) or else Nkind (P) = N_Entry_Declaration or else Nkind (D) = N_Defining_Identifier then @@ -560,21 +594,8 @@ package body Sem_Res is -------------------------------- procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id) is - Orig_Node : Node_Id := Original_Node (N); - begin - if Comes_From_Source (Orig_Node) - and then not In_Open_Scopes (Scope (T)) - and then not Is_Potentially_Use_Visible (T) - and then not In_Use (T) - and then not In_Use (Scope (T)) - and then (not Present (Entity (N)) - or else Ekind (Entity (N)) /= E_Function) - and then (Nkind (Orig_Node) /= N_Function_Call - or else Nkind (Name (Orig_Node)) /= N_Expanded_Name - or else Entity (Prefix (Name (Orig_Node))) /= Scope (T)) - and then not In_Instance - then + if Is_Invisible_Operator (N, T) then Error_Msg_NE ("operator for} is not directly visible!", N, First_Subtype (T)); Error_Msg_N ("use clause would make operation legal!", N); @@ -589,6 +610,44 @@ package body Sem_Res is P : Node_Id; C : Node_Id; + function Same_Argument_List return Boolean; + -- Check whether list of actuals is identical to list of formals + -- of called function (which is also the enclosing scope). + + ------------------------ + -- Same_Argument_List -- + ------------------------ + + function Same_Argument_List return Boolean is + A : Node_Id; + F : Entity_Id; + Subp : Entity_Id; + + begin + if not Is_Entity_Name (Name (N)) then + return False; + else + Subp := Entity (Name (N)); + end if; + + F := First_Formal (Subp); + A := First_Actual (N); + while Present (F) and then Present (A) loop + if not Is_Entity_Name (A) + or else Entity (A) /= F + then + return False; + end if; + + Next_Actual (A); + Next_Formal (F); + end loop; + + return True; + end Same_Argument_List; + + -- Start of processing for Check_Infinite_Recursion + begin -- Loop moving up tree, quitting if something tells us we are -- definitely not in an infinite recursion situation. @@ -608,6 +667,32 @@ package body Sem_Res is elsif Nkind (P) = N_Handled_Sequence_Of_Statements and then C /= First (Statements (P)) then + -- If the call is the expression of a return statement and + -- the actuals are identical to the formals, it's worth a + -- warning. However, we skip this if there is an immediately + -- preceding raise statement, since the call is never executed. + + -- Furthermore, this corresponds to a common idiom: + + -- function F (L : Thing) return Boolean is + -- begin + -- raise Program_Error; + -- return F (L); + -- end F; + + -- for generating a stub function + + if Nkind (Parent (N)) = N_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)))))); + end if; + return False; else @@ -615,10 +700,8 @@ package body Sem_Res is end if; end loop; - Warn_On_Instance := True; Error_Msg_N ("possible infinite recursion?", N); Error_Msg_N ("\Storage_Error may be raised at run time?", N); - Warn_On_Instance := False; return True; end Check_Infinite_Recursion; @@ -628,19 +711,25 @@ package body Sem_Res is ------------------------------- procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id) is - Typ : Entity_Id := Etype (First_Formal (Nam)); + Typ : constant Entity_Id := Etype (First_Formal (Nam)); function Uses_SS (T : Entity_Id) return Boolean; + -- Check whether the creation of an object of the type will involve + -- use of the secondary stack. If T is a record type, this is true + -- if the expression for some component uses the secondary stack, eg. + -- through a call to a function that returns an unconstrained value. + -- False if T is controlled, because cleanups occur elsewhere. + + ------------- + -- Uses_SS -- + ------------- function Uses_SS (T : Entity_Id) return Boolean is Comp : Entity_Id; Expr : Node_Id; begin - if Is_Controlled (T) - or else Has_Controlled_Component (T) - or else Functions_Return_By_DSP_On_Target - then + if Is_Controlled (T) then return False; elsif Is_Array_Type (T) then @@ -648,15 +737,17 @@ package body Sem_Res is elsif Is_Record_Type (T) then Comp := First_Component (T); - while Present (Comp) loop - if Ekind (Comp) = E_Component and then Nkind (Parent (Comp)) = N_Component_Declaration then Expr := Expression (Parent (Comp)); - if Nkind (Expr) = N_Function_Call + -- The expression for a dynamic component may be + -- rewritten as a dereference. Retrieve original + -- call. + + if Nkind (Original_Node (Expr)) = N_Function_Call and then Requires_Transient_Scope (Etype (Expr)) then return True; @@ -676,8 +767,18 @@ package body Sem_Res is end if; end Uses_SS; + -- Start of processing for Check_Initialization_Call + begin - if Uses_SS (Typ) then + -- 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 + + elsif Uses_SS (Typ) then Establish_Transient_Scope (First_Actual (N), Sec_Stack => True); end if; end Check_Initialization_Call; @@ -689,8 +790,70 @@ package body Sem_Res is procedure Check_Parameterless_Call (N : Node_Id) is Nam : Node_Id; + function Prefix_Is_Access_Subp return Boolean; + -- If the prefix is of an access_to_subprogram type, the node must be + -- rewritten as a call. Ditto if the prefix is overloaded and all its + -- interpretations are access to subprograms. + + --------------------------- + -- Prefix_Is_Access_Subp -- + --------------------------- + + function Prefix_Is_Access_Subp return Boolean is + I : Interp_Index; + It : Interp; + + begin + if not Is_Overloaded (N) then + return + Ekind (Etype (N)) = E_Subprogram_Type + and then Base_Type (Etype (Etype (N))) /= Standard_Void_Type; + else + Get_First_Interp (N, I, It); + while Present (It.Typ) loop + if Ekind (It.Typ) /= E_Subprogram_Type + or else Base_Type (Etype (It.Typ)) = Standard_Void_Type + then + return False; + end if; + + Get_Next_Interp (I, It); + end loop; + + return True; + end if; + end Prefix_Is_Access_Subp; + + -- Start of processing for Check_Parameterless_Call + begin - if Nkind (N) in N_Has_Etype and then Etype (N) = Any_Type then + -- Defend against junk stuff if errors already detected + + if Total_Errors_Detected /= 0 then + if Nkind (N) in N_Has_Etype and then Etype (N) = Any_Type then + return; + elsif Nkind (N) in N_Has_Chars + and then Chars (N) in Error_Name_Or_No_Name + then + return; + end if; + + Require_Entity (N); + end if; + + -- If the context expects a value, and the name is a procedure, + -- this is most likely a missing 'Access. Do not 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) + then return; end if; @@ -708,9 +871,7 @@ package body Sem_Res is -- procedure or entry. or else - (Nkind (N) = N_Explicit_Dereference - and then Ekind (Etype (N)) = E_Subprogram_Type - and then Base_Type (Etype (Etype (N))) /= Standard_Void_Type) + (Nkind (N) = N_Explicit_Dereference and then Prefix_Is_Access_Subp) -- Rewrite as call if it is a selected component which is a function, -- this is the case of a call to a protected function (which may be @@ -719,10 +880,11 @@ package body Sem_Res is or else (Nkind (N) = N_Selected_Component and then (Ekind (Entity (Selector_Name (N))) = E_Function - or else ((Ekind (Entity (Selector_Name (N))) = E_Entry - or else - Ekind (Entity (Selector_Name (N))) = E_Procedure) - and then Is_Overloaded (Selector_Name (N))))) + or else + ((Ekind (Entity (Selector_Name (N))) = E_Entry + or else + Ekind (Entity (Selector_Name (N))) = E_Procedure) + and then Is_Overloaded (Selector_Name (N))))) -- If one of the above three conditions is met, rewrite as call. -- Apply the rewriting only once. @@ -733,7 +895,7 @@ package body Sem_Res is then Nam := New_Copy (N); - -- If overloaded, overload set belongs to new copy. + -- If overloaded, overload set belongs to new copy Save_Interps (N, Nam); @@ -778,7 +940,8 @@ package body Sem_Res is Act1 : Node_Id := First_Actual (N); Act2 : Node_Id := Next_Actual (Act1); Error : Boolean := False; - Is_Binary : constant Boolean := Present (Act2); + Func : constant Entity_Id := Entity (Name (N)); + Is_Binary : constant Boolean := Present (Act2); Op_Node : Node_Id; Opnd_Type : Entity_Id; Orig_Type : Entity_Id := Empty; @@ -787,7 +950,7 @@ 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 acess type declared by an access decla- + -- 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; @@ -826,9 +989,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; @@ -896,9 +1057,7 @@ package body Sem_Res is else E := First_Entity (Pack); - while Present (E) loop - if Test (E) and then not In_Decl then @@ -912,10 +1071,6 @@ package body Sem_Res is end if; end Type_In_P; - --------------------------- - -- Operand_Type_In_Scope -- - --------------------------- - -- Start of processing for Make_Call_Into_Operator begin @@ -1051,7 +1206,11 @@ package body Sem_Res is or else Scope (Opnd_Type) /= System_Aux_Id or else Pack /= Scope (System_Aux_Id)) then - Error := True; + if not Is_Overloaded (Right_Opnd (Op_Node)) then + Error := True; + else + Error := not Operand_Type_In_Scope (Pack); + end if; elsif Pack = Standard_Standard and then not Operand_Type_In_Scope (Standard_Standard) @@ -1070,11 +1229,51 @@ package body Sem_Res is end if; Set_Chars (Op_Node, Op_Name); - Set_Etype (Op_Node, Base_Type (Etype (N))); + + if not Is_Private_Type (Etype (N)) then + Set_Etype (Op_Node, Base_Type (Etype (N))); + else + Set_Etype (Op_Node, Etype (N)); + end if; + + -- If this is a call to a function that renames a predefined equality, + -- the renaming declaration provides a type that must be used to + -- resolve the operands. This must be done now because resolution of + -- the equality node will not resolve any remaining ambiguity, and it + -- assumes that the first operand is not overloaded. + + if (Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne) + and then Ekind (Func) = E_Function + and then Is_Overloaded (Act1) + then + Resolve (Act1, Base_Type (Etype (First_Formal (Func)))); + Resolve (Act2, Base_Type (Etype (First_Formal (Func)))); + end if; + Set_Entity (Op_Node, Op_Id); Generate_Reference (Op_Id, N, ' '); Rewrite (N, Op_Node); - Resolve (N, Typ); + + -- If this is an arithmetic operator and the result type is private, + -- the operands and the result must be wrapped in conversion to + -- expose the underlying numeric type and expand the proper checks, + -- e.g. on division. + + if Is_Private_Type (Typ) then + case Nkind (N) is + when N_Op_Add | N_Op_Subtract | N_Op_Multiply | N_Op_Divide | + N_Op_Expon | N_Op_Mod | N_Op_Rem => + Resolve_Intrinsic_Operator (N, Typ); + + when N_Op_Plus | N_Op_Minus | N_Op_Abs => + Resolve_Intrinsic_Unary_Operator (N, Typ); + + when others => + Resolve (N, Typ); + end case; + else + Resolve (N, Typ); + end if; -- For predefined operators on literals, the operation freezes -- their type. @@ -1091,8 +1290,7 @@ package body Sem_Res is function Operator_Kind (Op_Name : Name_Id; - Is_Binary : Boolean) - return Node_Kind + Is_Binary : Boolean) return Node_Kind is Kind : Node_Kind; @@ -1155,7 +1353,7 @@ package body Sem_Res is Full_Analysis := Save_Full_Analysis; end Pre_Analyze_And_Resolve; - -- Version without context type. + -- Version without context type procedure Pre_Analyze_And_Resolve (N : Node_Id) is Save_Full_Analysis : constant Boolean := Full_Analysis; @@ -1244,6 +1442,7 @@ package body Sem_Res is 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; procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id); @@ -1283,7 +1482,8 @@ package body Sem_Res is Rewrite (N, Make_Character_Literal (Sloc (N), Chars => Name_Find, - Char_Literal_Value => Char_Code (Character'Pos ('A')))); + Char_Literal_Value => + UI_From_Int (Character'Pos ('A')))); Set_Etype (N, Any_Character); Set_Is_Static_Expression (N); @@ -1367,17 +1567,9 @@ package body Sem_Res is Is_Remote : Boolean := True; begin - -- Check that Typ is a fat pointer with a reference to a RAS as - -- original access type. + -- Check that Typ is a remote access-to-subprogram type - if - (Ekind (Typ) = E_Access_Subprogram_Type - and then Present (Equivalent_Type (Typ))) - or else - (Ekind (Typ) = E_Record_Type - and then Present (Corresponding_Remote_Type (Typ))) - - then + if Is_Remote_Access_To_Subprogram_Type (Typ) then -- Prefix (N) must statically denote a remote subprogram -- declared in a package specification. @@ -1406,9 +1598,15 @@ package body Sem_Res is end if; end if; - if Attr = Attribute_Access - or else Attr = Attribute_Unchecked_Access - or else Attr = Attribute_Unrestricted_Access + -- If we are generating code for a distributed program. + -- perform semantic checks against the corresponding + -- remote entities. + + if (Attr = Attribute_Access + or else Attr = Attribute_Unchecked_Access + or else Attr = Attribute_Unrestricted_Access) + and then Expander_Active + and then Get_PCS_Name /= Name_No_DSA then Check_Subtype_Conformant (New_Id => Entity (Prefix (N)), @@ -1425,14 +1623,16 @@ package body Sem_Res is Debug_A_Entry ("resolving ", N); - if Is_Fixed_Point_Type (Typ) then - Check_Restriction (No_Fixed_Point, N); + if Comes_From_Source (N) then + if Is_Fixed_Point_Type (Typ) then + Check_Restriction (No_Fixed_Point, N); - elsif Is_Floating_Point_Type (Typ) - and then Typ /= Universal_Real - and then Typ /= Any_Real - then - Check_Restriction (No_Floating_Point, N); + elsif Is_Floating_Point_Type (Typ) + and then Typ /= Universal_Real + and then Typ /= Any_Real + then + Check_Restriction (No_Floating_Point, N); + end if; end if; -- Return if already analyzed @@ -1461,17 +1661,21 @@ 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 - if Covers (Typ, It.Typ) then + if not Covers (Typ, It.Typ) then + if Debug_Flag_V then + Write_Str (" interpretation incompatible with context"); + Write_Eol; + end if; + else -- First matching interpretation if not Found then @@ -1480,7 +1684,7 @@ package body Sem_Res is Seen := It.Nam; Expr_Type := It.Typ; - -- Matching intepretation that is not the first, maybe an + -- Matching interpretation that is not the first, maybe an -- error, but there are some cases where preference rules are -- used to choose between the two possibilities. These and -- some more obscure cases are handled in Disambiguate. @@ -1489,8 +1693,18 @@ package body Sem_Res is Error_Msg_Sloc := Sloc (Seen); It1 := Disambiguate (N, I1, I, Typ); - if It1 = No_Interp then + -- Disambiguation has succeeded. Skip the remaining + -- interpretations. + + if It1 /= No_Interp then + Seen := It1.Nam; + Expr_Type := It1.Typ; + + while Present (It.Typ) loop + Get_Next_Interp (I, It); + end loop; + else -- Before we issue an ambiguity complaint, check for -- the case of a subprogram call where at least one -- of the arguments is Any_Type, and if so, suppress @@ -1500,10 +1714,11 @@ package body Sem_Res is or else Nkind (N) = 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; @@ -1544,23 +1759,61 @@ package body Sem_Res is Error_Msg_NE ("ambiguous expression (cannot resolve&)!", N, It.Nam); + Error_Msg_N ("possible interpretation#!", N); Ambiguous := True; end if; Error_Msg_Sloc := Sloc (It.Nam); - Error_Msg_N ("possible interpretation#!", N); - -- Disambiguation has succeeded. Skip the remaining - -- interpretations. - else - Seen := It1.Nam; - Expr_Type := It1.Typ; + -- By default, the error message refers to the candidate + -- interpretation. But if it is a predefined operator, + -- it is implicitly declared at the declaration of + -- the type of the operand. Recover the sloc of that + -- declaration for the error message. + + if Nkind (N) in N_Op + and then Scope (It.Nam) = Standard_Standard + and then not Is_Overloaded (Right_Opnd (N)) + and then Scope (Base_Type (Etype (Right_Opnd (N)))) + /= Standard_Standard + then + Err_Type := First_Subtype (Etype (Right_Opnd (N))); + + if Comes_From_Source (Err_Type) + and then Present (Parent (Err_Type)) + then + Error_Msg_Sloc := Sloc (Parent (Err_Type)); + end if; + + elsif Nkind (N) in N_Binary_Op + and then Scope (It.Nam) = Standard_Standard + and then not Is_Overloaded (Left_Opnd (N)) + and then Scope (Base_Type (Etype (Left_Opnd (N)))) + /= Standard_Standard + then + Err_Type := First_Subtype (Etype (Left_Opnd (N))); + + if Comes_From_Source (Err_Type) + and then Present (Parent (Err_Type)) + then + Error_Msg_Sloc := Sloc (Parent (Err_Type)); + end if; + else + Err_Type := Empty; + end if; + + if Nkind (N) in N_Op + and then Scope (It.Nam) = Standard_Standard + and then Present (Err_Type) + then + Error_Msg_N + ("possible interpretation (predefined)#!", N); + else + Error_Msg_N ("possible interpretation#!", N); + end if; - while Present (It.Typ) loop - Get_Next_Interp (I, It); - end loop; end if; end if; @@ -1619,13 +1872,6 @@ package body Sem_Res is Set_Etype (Name (N), Expr_Type); end if; - -- Here if interpetation is incompatible with context type - - else - if Debug_Flag_V then - Write_Str (" intepretation incompatible with context"); - Write_Eol; - end if; end if; -- Move to next interpretation @@ -1651,7 +1897,24 @@ package body Sem_Res is -- doesn't think of them this way!) if Typ = Standard_Void_Type then - Error_Msg_N ("expect procedure name in procedure call", N); + + -- Special case message if function used as a procedure + + if Nkind (N) = N_Procedure_Call_Statement + and then Is_Entity_Name (Name (N)) + and then Ekind (Entity (Name (N))) = E_Function + then + Error_Msg_NE + ("cannot use function & in a procedure call", + Name (N), Entity (Name (N))); + + -- Otherwise give general message (not clear what cases + -- this covers, but no harm in providing for them!) + + else + Error_Msg_N ("expect procedure name in procedure call", N); + end if; + Found := True; -- Otherwise we do have a subexpression with the wrong type @@ -1696,7 +1959,6 @@ package body Sem_Res is elsif Nkind (N) = N_Aggregate and then Etype (N) = Any_Composite then - -- Disable expansion in any case. If there is a type mismatch -- it may be fatal to try to expand the aggregate. The flag -- would otherwise be set to false when the error is posted. @@ -1733,6 +1995,10 @@ package body Sem_Res is end if; end Check_Aggr; + ---------------- + -- Check_Elmt -- + ---------------- + procedure Check_Elmt (Aelmt : Node_Id) is begin -- If we have a nested aggregate, go inside it (to @@ -1750,7 +2016,7 @@ package body Sem_Res is if not Is_Overloaded (Aelmt) and then Etype (Aelmt) /= Any_Fixed then - Resolve (Aelmt, Etype (Aelmt)); + Resolve (Aelmt); end if; if Etype (Aelmt) = Any_Type then @@ -1772,9 +2038,25 @@ package body Sem_Res is if Is_Overloaded (N) and then Nkind (N) = N_Function_Call then - Error_Msg_Node_2 := Typ; - Error_Msg_NE ("no visible interpretation of&" & - " matches expected type&", N, Name (N)); + declare + Subp_Name : Node_Id; + begin + if Is_Entity_Name (Name (N)) then + Subp_Name := Name (N); + + elsif Nkind (Name (N)) = N_Selected_Component then + + -- Protected operation: retrieve operation name + + Subp_Name := Selector_Name (Name (N)); + else + raise Program_Error; + end if; + + Error_Msg_Node_2 := Typ; + Error_Msg_NE ("no visible interpretation of&" & + " matches expected type&", N, Subp_Name); + end; if All_Errors_Mode then declare @@ -1783,10 +2065,9 @@ package body Sem_Res is begin Error_Msg_N ("\possible interpretations:", N); - Get_First_Interp (Name (N), Index, It); + 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&", @@ -1816,28 +2097,6 @@ package body Sem_Res is -- Here we have an acceptable interpretation for the context else - -- A user-defined operator is tranformed into a function call at - -- this point, so that further processing knows that operators are - -- really operators (i.e. are predefined operators). User-defined - -- operators that are intrinsic are just renamings of the predefined - -- ones, and need not be turned into calls either, but if they rename - -- a different operator, we must transform the node accordingly. - -- Instantiations of Unchecked_Conversion are intrinsic but are - -- treated as functions, even if given an operator designator. - - if Nkind (N) in N_Op - and then Present (Entity (N)) - and then Ekind (Entity (N)) /= E_Operator - then - - if not Is_Predefined_Op (Entity (N)) then - Rewrite_Operator_As_Call (N, Entity (N)); - - elsif Present (Alias (Entity (N))) then - Rewrite_Renamed_Operator (N, Alias (Entity (N))); - end if; - end if; - -- Propagate type information and normalize tree for various -- predefined operations. If the context only imposes a class of -- types, rather than a specific type, propagate the actual type @@ -1858,12 +2117,45 @@ package body Sem_Res is if Typ = Any_Real and then Expr_Type = Any_Fixed then - Error_Msg_N ("Illegal context for mixed mode operation", N); + Error_Msg_N ("illegal context for mixed mode operation", N); Set_Etype (N, Universal_Real); Ctx_Type := Universal_Real; end if; end if; + -- A user-defined operator is tranformed into a function call at + -- this point, so that further processing knows that operators are + -- really operators (i.e. are predefined operators). User-defined + -- operators that are intrinsic are just renamings of the predefined + -- ones, and need not be turned into calls either, but if they rename + -- a different operator, we must transform the node accordingly. + -- Instantiations of Unchecked_Conversion are intrinsic but are + -- treated as functions, even if given an operator designator. + + if Nkind (N) in N_Op + and then Present (Entity (N)) + and then Ekind (Entity (N)) /= E_Operator + then + + if not Is_Predefined_Op (Entity (N)) then + Rewrite_Operator_As_Call (N, Entity (N)); + + elsif Present (Alias (Entity (N))) + and then + Nkind (Parent (Parent (Entity (N)))) + = N_Subprogram_Renaming_Declaration + then + Rewrite_Renamed_Operator (N, Alias (Entity (N)), Typ); + + -- If the node is rewritten, it will be fully resolved in + -- Rewrite_Renamed_Operator. + + if Analyzed (N) then + return; + end if; + end if; + end if; + case N_Subexpr'(Nkind (N)) is when N_Aggregate => Resolve_Aggregate (N, Ctx_Type); @@ -1992,7 +2284,7 @@ package body Sem_Res is Set_Is_Overloaded (N, False); -- Freeze expression type, entity if it is a name, and designated - -- type if it is an allocator (RM 13.14(9,10)). + -- type if it is an allocator (RM 13.14(10,11,13)). -- Now that the resolution of the type of the node is complete, -- and we did not detect an error, we can expand this node. We @@ -2011,16 +2303,19 @@ package body Sem_Res is Expand (N); end if; - end Resolve; - -- Version with check(s) suppressed - + ------------- + -- Resolve -- + ------------- + + -- Version with check(s) suppressed + procedure Resolve (N : Node_Id; Typ : Entity_Id; Suppress : Check_Id) is begin if Suppress = All_Checks then declare - Svg : constant Suppress_Record := Scope_Suppress; + Svg : constant Suppress_Array := Scope_Suppress; begin Scope_Suppress := (others => True); @@ -2030,16 +2325,27 @@ package body Sem_Res is else declare - Svg : constant Boolean := Get_Scope_Suppress (Suppress); + Svg : constant Boolean := Scope_Suppress (Suppress); begin - Set_Scope_Suppress (Suppress, True); + Scope_Suppress (Suppress) := True; Resolve (N, Typ); - Set_Scope_Suppress (Suppress, Svg); + Scope_Suppress (Suppress) := Svg; end; end if; end Resolve; + ------------- + -- Resolve -- + ------------- + + -- Version with implicit type + + procedure Resolve (N : Node_Id) is + begin + Resolve (N, Etype (N)); + end Resolve; + --------------------- -- Resolve_Actuals -- --------------------- @@ -2057,6 +2363,11 @@ package body Sem_Res is -- an instance of the default expression. The insertion is always -- a named association. + function Same_Ancestor (T1, T2 : Entity_Id) return Boolean; + -- Check whether T1 and T2, or their full views, are derived from a + -- common type. Used to enforce the restrictions on array conversions + -- of AI95-00246. + -------------------- -- Insert_Default -- -------------------- @@ -2066,13 +2377,17 @@ package body Sem_Res is Assoc : Node_Id; begin - -- Note that we do a full New_Copy_Tree, so that any associated - -- Itypes are properly copied. This may not be needed any more, - -- but it does no harm as a safety measure! Defaults of a generic - -- formal may be out of bounds of the corresponding actual (see - -- cc1311b) and an additional check may be required. + -- Missing argument in call, nothing to insert - if Present (Default_Value (F)) then + 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); @@ -2105,9 +2420,6 @@ package body Sem_Res is end if; Set_Parent (Actval, N); - Analyze_And_Resolve (Actval, Etype (Actval)); - else - Set_Parent (Actval, N); -- Resolve aggregates with their base type, to avoid scope -- anomalies: the subtype was first built in the suprogram @@ -2120,6 +2432,28 @@ package body Sem_Res is else Analyze_And_Resolve (Actval, Etype (Actval)); end if; + + else + Set_Parent (Actval, N); + + -- See note above concerning aggregates + + if Nkind (Actval) = N_Aggregate + and then Has_Discriminants (Etype (Actval)) + then + Analyze_And_Resolve (Actval, Base_Type (Etype (Actval))); + + -- Resolve entities with their own type, which may differ + -- from the type of a reference in a generic context (the + -- view swapping mechanism did not anticipate the re-analysis + -- of default values in calls). + + elsif Is_Entity_Name (Actval) then + Analyze_And_Resolve (Actval, Etype (Entity (Actval))); + + else + Analyze_And_Resolve (Actval, Etype (Actval)); + end if; end if; -- If default is a tag indeterminate function call, propagate @@ -2131,9 +2465,6 @@ package body Sem_Res is Set_Is_Controlling_Actual (Actval); end if; - else - -- Missing argument in call, nothing to insert. - return; end if; -- If the default expression raises constraint error, then just @@ -2142,7 +2473,8 @@ package body Sem_Res is if Raises_Constraint_Error (Actval) then Rewrite (Actval, - Make_Raise_Constraint_Error (Loc)); + Make_Raise_Constraint_Error (Loc, + Reason => CE_Range_Check_Failed)); Set_Raises_Constraint_Error (Actval); Set_Etype (Actval, Etype (F)); end if; @@ -2186,13 +2518,49 @@ package body Sem_Res is Prev := Actval; end Insert_Default; + ------------------- + -- Same_Ancestor -- + ------------------- + + function Same_Ancestor (T1, T2 : Entity_Id) return Boolean is + FT1 : Entity_Id := T1; + FT2 : Entity_Id := T2; + + begin + if Is_Private_Type (T1) + and then Present (Full_View (T1)) + then + FT1 := Full_View (T1); + end if; + + if Is_Private_Type (T2) + and then Present (Full_View (T2)) + then + FT2 := Full_View (T2); + end if; + + return Root_Type (Base_Type (FT1)) = Root_Type (Base_Type (FT2)); + end Same_Ancestor; + -- Start of processing for Resolve_Actuals begin A := First_Actual (N); F := First_Formal (Nam); - while Present (F) loop + if No (A) and then Needs_No_Actuals (Nam) then + null; + + -- If we have an error in any actual or formal, indicated by + -- a type of Any_Type, then abandon resolution attempt, and + -- set result type to Any_Type. + + elsif (Present (A) and then Etype (A) = Any_Type) + or else Etype (F) = Any_Type + then + Set_Etype (N, Any_Type); + return; + end if; if Present (A) and then (Nkind (Parent (A)) /= N_Parameter_Association @@ -2202,54 +2570,121 @@ package body Sem_Res is -- 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 a + -- 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 excpetion is the case of reference to a + -- component or subcomponent of a bit-packed array, in which case + -- we want to defer expansion to the point the in and out + -- assignments are performed. if Ekind (F) /= E_In_Parameter and then Nkind (A) = N_Type_Conversion and then not Is_Class_Wide_Type (Etype (Expression (A))) then - if Conversion_OK (A) - or else Valid_Conversion (A, Etype (A), Expression (A)) + if Ekind (F) = E_In_Out_Parameter + and then Is_Array_Type (Etype (F)) then - Resolve (Expression (A), Etype (Expression (A))); + 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) + + elsif Has_Aliased_Components (Etype (F)) + and then + not Has_Aliased_Components (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); + 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))) + and then not Is_Ref_To_Bit_Packed_Array (Expression (A)) + then + Resolve (Expression (A)); end if; else + if Nkind (A) = N_Type_Conversion + and then Is_Array_Type (Etype (F)) + and then not Same_Ancestor (Etype (F), Etype (Expression (A))) + and then + (Is_Limited_Type (Etype (F)) + or else Is_Limited_Type (Etype (Expression (A)))) + then + Error_Msg_N + ("conversion between unrelated limited array types " & + "not allowed (\A\I-00246)", A); + + if Is_Limited_Type (Etype (F)) then + Explain_Limited_Type (Etype (F), A); + end if; + + if Is_Limited_Type (Etype (Expression (A))) then + Explain_Limited_Type (Etype (Expression (A)), A); + end if; + end if; + Resolve (A, Etype (F)); end if; A_Typ := Etype (A); F_Typ := Etype (F); - if Ekind (F) /= E_In_Parameter - and then not Is_OK_Variable_For_Out_Formal (A) - then - -- Specialize error message for protected procedure call - -- within function call of the same protected object. - - if Is_Entity_Name (A) - and then Chars (Entity (A)) = Name_uObject - and then Ekind (Current_Scope) = E_Function - and then Convention (Current_Scope) = Convention_Protected - and then Ekind (Nam) /= E_Function + -- Perform error checks for IN and IN OUT parameters + + if Ekind (F) /= E_Out_Parameter then + + -- Check unset reference. For scalar parameters, it is clearly + -- wrong to pass an uninitialized value as either an IN or + -- IN-OUT parameter. For composites, it is also clearly an + -- error to pass a completely uninitialized value as an IN + -- parameter, but the case of IN OUT is trickier. We prefer + -- not to give a warning here. For example, suppose there is + -- a routine that sets some component of a record to False. + -- It is perfectly reasonable to make this IN-OUT and allow + -- either initialized or uninitialized records to be passed + -- in this case. + + -- For partially initialized composite values, we also avoid + -- warnings, since it is quite likely that we are passing a + -- partially initialized value and only the initialized fields + -- will in fact be read in the subprogram. + + if Is_Scalar_Type (A_Typ) + or else (Ekind (F) = E_In_Parameter + and then not Is_Partially_Initialized_Type (A_Typ)) then - Error_Msg_N ("within protected function, protected " & - "object is constant", A); - Error_Msg_N ("\cannot call operation that may modify it", A); - else - Error_Msg_NE ("actual for& must be a variable", A, F); + Check_Unset_Reference (A); end if; - end if; - if Ekind (F) /= E_Out_Parameter then - Check_Unset_Reference (A); + -- In Ada 83 we cannot pass an OUT parameter as an IN or IN OUT + -- actual to a nested call, since this is case of reading an + -- out parameter, which is not allowed. - if Ada_83 + if Ada_Version = Ada_83 and then Is_Entity_Name (A) and then Ekind (Entity (A)) = E_Out_Parameter then @@ -2257,6 +2692,23 @@ 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); + + if Is_Entity_Name (A) then + Kill_Checks (Entity (A)); + else + Kill_All_Checks; + end if; + end if; + + if Etype (A) = Any_Type then + Set_Etype (N, Any_Type); + return; + end if; + -- Apply appropriate range checks for in, out, and in-out -- parameters. Out and in-out parameters also need a separate -- check, if there is a type conversion, to make sure the return @@ -2300,12 +2752,25 @@ package body Sem_Res is else Apply_Range_Check (A, F_Typ); end if; + + -- Ada 2005 (AI-231) + + if Ada_Version >= Ada_05 + and then Is_Access_Type (F_Typ) + and then Can_Never_Be_Null (F_Typ) + and then 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; end if; if Ekind (F) = E_Out_Parameter or else Ekind (F) = E_In_Out_Parameter then - if Nkind (A) = N_Type_Conversion then if Is_Scalar_Type (A_Typ) then Apply_Scalar_Range_Check @@ -2376,27 +2841,34 @@ package body Sem_Res is and then not Is_Controlling_Formal (F) then Error_Msg_N ("class-wide argument not allowed here!", A); - if Is_Subprogram (Nam) then + + if Is_Subprogram (Nam) + and then Comes_From_Source (Nam) + then Error_Msg_Node_2 := F_Typ; Error_Msg_NE - ("& is not a primitive operation of &!", A, Nam); + ("& is not a dispatching operation of &!", A, Nam); end if; elsif Is_Access_Type (A_Typ) and then Is_Access_Type (F_Typ) and then Ekind (F_Typ) /= E_Access_Subprogram_Type and then (Is_Class_Wide_Type (Designated_Type (A_Typ)) - or else (Nkind (A) = N_Attribute_Reference - and then Is_Class_Wide_Type (Etype (Prefix (A))))) + or else (Nkind (A) = N_Attribute_Reference + and then + Is_Class_Wide_Type (Etype (Prefix (A))))) and then not Is_Class_Wide_Type (Designated_Type (F_Typ)) and then not Is_Controlling_Formal (F) then Error_Msg_N ("access to class-wide argument not allowed here!", A); - if Is_Subprogram (Nam) then + + if Is_Subprogram (Nam) + and then Comes_From_Source (Nam) + then Error_Msg_Node_2 := Designated_Type (F_Typ); Error_Msg_NE - ("& is not a primitive operation of &!", A, Nam); + ("& is not a dispatching operation of &!", A, Nam); end if; end if; @@ -2413,15 +2885,21 @@ package body Sem_Res is end if; Prev := A; + + if Ekind (F) /= E_Out_Parameter then + Check_Unset_Reference (A); + end if; + Next_Actual (A); + -- Case where actual is not present + else Insert_Default; end if; Next_Formal (F); end loop; - end Resolve_Actuals; ----------------------- @@ -2435,6 +2913,27 @@ package body Sem_Res is Constr : Node_Id; Disc_Exp : Node_Id; + 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. + + ---------------------------- + -- In_Dispatching_Context -- + ---------------------------- + + 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) + and then Is_Entity_Name (Name (Par)) + and then Is_Dispatching_Operation (Entity (Name (Par))); + end In_Dispatching_Context; + + -- Start of processing for Resolve_Allocator + begin -- Replace general access with specific type @@ -2452,6 +2951,7 @@ package body Sem_Res is if Nkind (E) = N_Qualified_Expression then if Is_Class_Wide_Type (Etype (E)) and then not Is_Class_Wide_Type (Designated_Type (Typ)) + and then not In_Dispatching_Context then Error_Msg_N ("class-wide allocator not allowed for this access type", N); @@ -2460,6 +2960,16 @@ package body Sem_Res is Resolve (Expression (E), Etype (E)); Check_Unset_Reference (Expression (E)); + -- A qualified expression requires an exact match of the type, + -- class-wide matching is not allowed. + + if (Is_Class_Wide_Type (Etype (Expression (E))) + or else Is_Class_Wide_Type (Etype (E))) + and then Base_Type (Etype (Expression (E))) /= Base_Type (Etype (E)) + then + Wrong_Type (Expression (E), Etype (E)); + end if; + -- For a subtype mark or subtype indication, freeze the subtype else @@ -2489,7 +2999,6 @@ package body Sem_Res is 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 @@ -2535,18 +3044,69 @@ package body Sem_Res is end if; end if; + -- Ada 2005 (AI-344): A class-wide allocator requires an accessibility + -- check that the level of the type of the created object is not deeper + -- than the level of the allocator's access type, since extensions can + -- now occur at deeper levels than their ancestor types. This is a + -- static accessibility level check; a run-time check is also needed in + -- the case of an initialized allocator with a class-wide argument (see + -- Expand_Allocator_Expression). + + if Ada_Version >= Ada_05 + and then Is_Class_Wide_Type (Designated_Type (Typ)) + then + declare + Exp_Typ : Entity_Id; + + begin + if Nkind (E) = N_Qualified_Expression then + Exp_Typ := Etype (E); + elsif Nkind (E) = N_Subtype_Indication then + Exp_Typ := Entity (Subtype_Mark (Original_Node (E))); + else + Exp_Typ := Entity (E); + end if; + + if Type_Access_Level (Exp_Typ) > Type_Access_Level (Typ) then + if In_Instance_Body then + Error_Msg_N ("?type in allocator has deeper level than" & + " designated class-wide type", E); + Error_Msg_N ("?Program_Error will be raised at run time", E); + Rewrite (N, + Make_Raise_Program_Error (Sloc (N), + Reason => PE_Accessibility_Check_Failed)); + Set_Etype (N, Typ); + else + Error_Msg_N ("type in allocator has deeper level than" & + " designated class-wide type", E); + end if; + end if; + end; + end if; + -- Check for allocation from an empty storage pool if No_Pool_Assigned (Typ) then declare Loc : constant Source_Ptr := Sloc (N); - begin Error_Msg_N ("?allocation from empty storage pool!", N); Error_Msg_N ("?Storage_Error will be raised at run time!", N); Insert_Action (N, - Make_Raise_Storage_Error (Loc)); + 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; end Resolve_Allocator; @@ -2557,11 +3117,12 @@ package body Sem_Res is -- Used for resolving all arithmetic operators except exponentiation procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id) is - L : constant Node_Id := Left_Opnd (N); - R : constant Node_Id := Right_Opnd (N); - T : Entity_Id; - TL : Entity_Id := Base_Type (Etype (L)); - TR : Entity_Id := Base_Type (Etype (R)); + L : constant Node_Id := Left_Opnd (N); + R : constant Node_Id := Right_Opnd (N); + TL : constant Entity_Id := Base_Type (Etype (L)); + TR : constant Entity_Id := Base_Type (Etype (R)); + T : Entity_Id; + Rop : Node_Id; B_Typ : constant Entity_Id := Base_Type (Typ); -- We do the resolution using the base type, because intermediate values @@ -2578,9 +3139,6 @@ package body Sem_Res is procedure Set_Operand_Type (N : Node_Id); -- Set operand type to T if universal - function Universal_Interpretation (N : Node_Id) return Entity_Id; - -- Find universal type of operand, if any. - ----------------------------- -- Is_Integer_Or_Universal -- ----------------------------- @@ -2598,9 +3156,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 @@ -2627,8 +3183,8 @@ package body Sem_Res is if Universal_Interpretation (N) = Universal_Integer then -- A universal integer literal is resolved as standard integer - -- except in the case of a fixed-point result, where we leave - -- it as universal (to be handled by Exp_Fixd later on) + -- except in the case of a fixed-point result, where we leave it + -- as universal (to be handled by Exp_Fixd later on) if Is_Fixed_Point_Type (T) then Resolve (N, Universal_Integer); @@ -2659,13 +3215,13 @@ package body Sem_Res is elsif Etype (N) = T and then B_Typ /= Universal_Fixed then - -- Not a mixed-mode operation. Resolve with context. + -- Not a mixed-mode operation, resolve with context Resolve (N, B_Typ); elsif Etype (N) = Any_Fixed then - -- N may itself be a mixed-mode operation, so use context type. + -- N may itself be a mixed-mode operation, so use context type Resolve (N, B_Typ); @@ -2688,9 +3244,7 @@ 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 if Analyzed (N) then @@ -2711,18 +3265,37 @@ package body Sem_Res is Get_Next_Interp (Index, It); end loop; - -- Reanalyze the literal with the fixed type of the context. + -- Reanalyze the literal with the fixed type of the context. If + -- context is Universal_Fixed, we are within a conversion, leave + -- the literal as a universal real because there is no usable + -- fixed type, and the target of the conversion plays no role in + -- the resolution. - if N = L then - Set_Analyzed (R, False); - Resolve (R, B_Typ); - else - Set_Analyzed (L, False); - Resolve (L, B_Typ); - end if; + declare + Op2 : Node_Id; + T2 : Entity_Id; + + begin + if N = L then + Op2 := R; + else + Op2 := L; + end if; + + if B_Typ = Universal_Fixed + and then Nkind (Op2) = N_Real_Literal + then + T2 := Universal_Real; + else + T2 := B_Typ; + end if; + + Set_Analyzed (Op2, False); + Resolve (Op2, T2); + end; else - Resolve (N, Etype (N)); + Resolve (N); end if; end Set_Mixed_Mode_Operand; @@ -2739,50 +3312,13 @@ package body Sem_Res is end if; end Set_Operand_Type; - ------------------------------ - -- Universal_Interpretation -- - ------------------------------ - - function Universal_Interpretation (N : Node_Id) return Entity_Id is - Index : Interp_Index; - It : Interp; - - begin - if not Is_Overloaded (N) then - - if Etype (N) = Universal_Integer - or else Etype (N) = Universal_Real - then - return Etype (N); - else - return Empty; - end if; - - else - Get_First_Interp (N, Index, It); - - while Present (It.Typ) loop - - if It.Typ = Universal_Integer - or else It.Typ = Universal_Real - then - return It.Typ; - end if; - - Get_Next_Interp (Index, It); - end loop; - - return Empty; - end if; - end Universal_Interpretation; - -- Start of processing for Resolve_Arithmetic_Op begin if Comes_From_Source (N) and then Ekind (Entity (N)) = E_Function and then Is_Imported (Entity (N)) - and then Present (First_Rep_Item (Entity (N))) + and then Is_Intrinsic_Subprogram (Entity (N)) then Resolve_Intrinsic_Operator (N, Typ); return; @@ -2856,7 +3392,7 @@ package body Sem_Res is Set_Etype (R, Any_Type); else - if Ada_83 + 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 @@ -2926,7 +3462,7 @@ package body Sem_Res is Set_Operand_Type (R); end if; - Generate_Operator_Reference (N); + Generate_Operator_Reference (N, Typ); Eval_Arithmetic_Op (N); -- Set overflow and division checking bit. Much cleverer code needed @@ -2936,21 +3472,39 @@ package body Sem_Res is if Nkind (N) in N_Op then if not Overflow_Checks_Suppressed (Etype (N)) then - Set_Do_Overflow_Check (N); + Enable_Overflow_Check (N); end if; + -- 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) and then not Division_Checks_Suppressed (Etype (N)) then - Set_Do_Division_Check (N); + Rop := Right_Opnd (N); + + if Compile_Time_Known_Value (Rop) + and then ((Is_Integer_Type (Etype (Rop)) + and then Expr_Value (Rop) = Uint_0) + or else + (Is_Real_Type (Etype (Rop)) + and then Expr_Value_R (Rop) = Ureal_0)) + then + Apply_Compile_Time_Constraint_Error + (N, "division by zero?", CE_Divide_By_Zero, + Loc => Sloc (Right_Opnd (N))); + + -- Otherwise just set the flag to check at run time + + else + Set_Do_Division_Check (N); + end if; end if; end if; Check_Unset_Reference (L); Check_Unset_Reference (R); - end Resolve_Arithmetic_Op; ------------------ @@ -2965,32 +3519,31 @@ package body Sem_Res is It : Interp; Norm_OK : Boolean; Scop : Entity_Id; + W : Node_Id; begin - -- The context imposes a unique interpretation with type Typ on - -- a procedure or function call. Find the entity of the subprogram - -- that yields the expected type, and propagate the corresponding - -- formal constraints on the actuals. The caller has established - -- that an interpretation exists, and emitted an error if not unique. + -- The context imposes a unique interpretation with type Typ on a + -- procedure or function call. Find the entity of the subprogram that + -- yields the expected type, and propagate the corresponding formal + -- constraints on the actuals. The caller has established that an + -- interpretation exists, and emitted an error if not unique. -- First deal with the case of a call to an access-to-subprogram, -- dereference made explicit in Analyze_Call. if Ekind (Etype (Subp)) = E_Subprogram_Type then - if not Is_Overloaded (Subp) then Nam := Etype (Subp); else - -- Find the interpretation whose type (a subprogram type) - -- has a return type that is compatible with the context. - -- Analysis of the node has established that one exists. + -- Find the interpretation whose type (a subprogram type) has a + -- return type that is compatible with the context. Analysis of + -- the node has established that one exists. - Get_First_Interp (Subp, I, It); Nam := Empty; + Get_First_Interp (Subp, I, It); while Present (It.Typ) loop - if Covers (Typ, Etype (It.Typ)) then Nam := It.Typ; exit; @@ -3010,10 +3563,18 @@ package body Sem_Res is Resolve (Subp, Nam); end if; - -- If this is a procedure call which is really an entry call, do - -- the conversion of the procedure call to an entry call. Protected - -- operations use the same circuitry because the name in the call - -- can be an arbitrary expression with special resolution rules. + -- 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 + -- knowledge of current constant values. + + Kill_Current_Values; + + -- If this is a procedure call which is really an entry call, do the + -- conversion of the procedure call to an entry call. Protected + -- operations use the same circuitry because the name in the call can be + -- an arbitrary expression with special resolution rules. elsif Nkind (Subp) = N_Selected_Component or else Nkind (Subp) = N_Indexed_Component @@ -3022,6 +3583,11 @@ package body Sem_Res is then Resolve_Entry_Call (N, Typ); Check_Elab_Call (N); + + -- Kill checks and constant values, as above for indirect case + -- Who knows what happens when another task is activated? + + Kill_Current_Values; return; -- Normal subprogram call with name established in Resolve @@ -3035,10 +3601,9 @@ package body Sem_Res is else pragma Assert (Is_Overloaded (Subp)); - Nam := Empty; -- We know that it will be assigned in loop below. + Nam := Empty; -- We know that it will be assigned in loop below Get_First_Interp (Subp, I, It); - while Present (It.Typ) loop if Covers (Typ, It.Typ) then Nam := It.Nam; @@ -3073,48 +3638,132 @@ package body Sem_Res is end; end if; - -- Check that a procedure call does not occur in the context - -- of the entry call statement of a conditional or timed - -- entry call. Note that the case of a call to a subprogram - -- renaming of an entry will also be rejected. The test - -- for N not being an N_Entry_Call_Statement is defensive, - -- covering the possibility that the processing of entry - -- calls might reach this point due to later modifications - -- of the code above. + -- Cannot call thread body directly + + 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; + end if; + + -- Check that a procedure call does not occur in the context of the + -- entry call statement of a conditional or timed entry call. Note that + -- the case of a call to a subprogram renaming of an entry will also be + -- rejected. The test for N not being an N_Entry_Call_Statement is + -- defensive, covering the possibility that the processing of entry + -- calls might reach this point due to later modifications of the code + -- above. if Nkind (Parent (N)) = N_Entry_Call_Alternative and then Nkind (N) /= N_Entry_Call_Statement and then Entry_Call_Statement (Parent (N)) = N then - Error_Msg_N ("entry call required in select statement", N); + 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 pro- + -- cedure_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 + ("procedure or entry call required in select statement", N); + end if; end if; - -- Freeze the subprogram name if not in default expression. Note - -- that we freeze procedure calls as well as function calls. - -- Procedure calls are not frozen according to the rules (RM - -- 13.14(14)) because it is impossible to have a procedure call to - -- a non-frozen procedure in pure Ada, but in the code that we - -- generate in the expander, this rule needs extending because we - -- can generate procedure calls that need freezing. + -- Check that this is not a call to a protected procedure or + -- entry from within a protected function. + + if Ekind (Current_Scope) = E_Function + and then Ekind (Scope (Current_Scope)) = E_Protected_Type + and then Ekind (Nam) /= E_Function + and then Scope (Nam) = Scope (Current_Scope) + then + Error_Msg_N ("within protected function, protected " & + "object is constant", N); + Error_Msg_N ("\cannot call operation that may modify it", N); + end if; + + -- Freeze the subprogram name if not in default expression. Note that we + -- freeze procedure calls as well as function calls. Procedure calls are + -- not frozen according to the rules (RM 13.14(14)) because it is + -- impossible to have a procedure call to a non-frozen procedure in pure + -- Ada, but in the code that we generate in the expander, this rule + -- needs extending because we can generate procedure calls that need + -- freezing. if Is_Entity_Name (Subp) and then not In_Default_Expression then Freeze_Expression (Subp); end if; - -- For a predefined operator, the type of the result is the type - -- imposed by context, except for a predefined operation on universal - -- fixed. Otherwise The type of the call is the type returned by the - -- subprogram being called. + -- For a predefined operator, the type of the result is the type imposed + -- by context, except for a predefined operation on universal fixed. + -- Otherwise The type of the call is the type returned by the subprogram + -- being called. if Is_Predefined_Op (Nam) then - if Etype (N) /= Universal_Fixed then Set_Etype (N, Typ); end if; - -- If the subprogram returns an array type, and the context - -- requires the component type of that array type, the node is - -- really an indexing of the parameterless call. Resolve as such. + -- If the subprogram returns an array type, and the context requires the + -- component type of that array type, the node is really an indexing of + -- the parameterless call. Resolve as such. A pathological case occurs + -- when the type of the component is an access to the array type. In + -- this case the call is truly ambiguous. elsif Needs_No_Actuals (Nam) and then @@ -3128,25 +3777,36 @@ package body Sem_Res is then declare Index_Node : Node_Id; + New_Subp : Node_Id; + Ret_Type : constant Entity_Id := Etype (Nam); begin - Check_Elab_Call (N); - - if Component_Type (Etype (Nam)) /= Any_Type then - Index_Node := - Make_Indexed_Component (Loc, - Prefix => - Make_Function_Call (Loc, - Name => New_Occurrence_Of (Nam, Loc)), - Expressions => Parameter_Associations (N)); - - -- Since we are correcting a node classification error made by - -- the parser, we call Replace rather than Rewrite. - - Replace (N, Index_Node); - Set_Etype (Prefix (N), Etype (Nam)); - Set_Etype (N, Typ); - Resolve_Indexed_Component (N, Typ); + if Is_Access_Type (Ret_Type) + and then Ret_Type = Component_Type (Designated_Type (Ret_Type)) + then + Error_Msg_N + ("cannot disambiguate function call and indexing", N); + else + New_Subp := Relocate_Node (Subp); + Set_Entity (Subp, Nam); + + if Component_Type (Ret_Type) /= Any_Type then + Index_Node := + Make_Indexed_Component (Loc, + Prefix => + Make_Function_Call (Loc, + Name => New_Subp), + Expressions => Parameter_Associations (N)); + + -- Since we are correcting a node classification error made + -- by the parser, we call Replace rather than Rewrite. + + Replace (N, Index_Node); + Set_Etype (Prefix (N), Ret_Type); + Set_Etype (N, Typ); + Resolve_Indexed_Component (N, Typ); + Check_Elab_Call (Prefix (N)); + end if; end if; return; @@ -3174,15 +3834,15 @@ package body Sem_Res is Set_Is_Overloaded (Subp, False); Set_Is_Overloaded (N, False); - -- If we are calling the current subprogram from immediately within - -- its body, then that is the case where we can sometimes detect - -- cases of infinite recursion statically. Do not try this in case - -- restriction No_Recursion is in effect anyway. + -- If we are calling the current subprogram from immediately within its + -- body, then that is the case where we can sometimes detect cases of + -- infinite recursion statically. Do not try this in case restriction + -- No_Recursion is in effect anyway. Scop := Current_Scope; if Nam = Scop - and then not Restrictions (No_Recursion) + and then not Restriction_Active (No_Recursion) and then Check_Infinite_Recursion (N) then -- Here we detected and flagged an infinite recursion, so we do @@ -3208,6 +3868,7 @@ package body Sem_Res is -- 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. @@ -3245,8 +3906,9 @@ package body Sem_Res is return; end if; - -- Create a transient scope if the resulting type requires it. - -- There are 3 notable exceptions: in init_procs, the transient scope + -- 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 @@ -3255,7 +3917,7 @@ package body Sem_Res is -- 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 + -- for it, precisely because we will not do it within the init proc -- itself. if Expander_Active @@ -3268,7 +3930,14 @@ package body Sem_Res is Establish_Transient_Scope (N, Sec_Stack => not Functions_Return_By_DSP_On_Target); - elsif Chars (Nam) = Name_uInit_Proc + -- If the call appears within the bounds of a loop, it will + -- be rewritten and reanalyzed, nothing left to do here. + + if Nkind (N) /= N_Function_Call then + return; + end if; + + elsif Is_Init_Proc (Nam) and then not Within_Init_Proc then Check_Initialization_Call (N, Nam); @@ -3299,7 +3968,7 @@ package body Sem_Res is Copy_Node (Subp, N); Resolve_Entity_Name (N, Typ); - -- Avoid validation, since it is a static function call. + -- Avoid validation, since it is a static function call return; end if; @@ -3312,18 +3981,6 @@ package body Sem_Res is then Check_Dispatching_Call (N); - -- If the subprogram is abstract, check that the call has a - -- controlling argument (i.e. is dispatching) or is disptaching on - -- result - - if Is_Abstract (Nam) - and then No (Controlling_Argument (N)) - and then not Is_Class_Wide_Type (Typ) - and then not Is_Tag_Indeterminate (N) - then - Error_Msg_N ("call to abstract subprogram must be dispatching", N); - end if; - elsif Is_Abstract (Nam) and then not In_Instance then @@ -3334,10 +3991,8 @@ package body Sem_Res is Check_Intrinsic_Call (N); end if; - -- If we fall through we definitely have a non-static call - + Eval_Call (N); Check_Elab_Call (N); - end Resolve_Call; ------------------------------- @@ -3354,11 +4009,12 @@ package body Sem_Res is Set_Etype (N, B_Typ); Eval_Character_Literal (N); - -- Wide_Character literals must always be defined, since the set of - -- wide character literals is complete, i.e. if a character literal - -- is accepted by the parser, then it is OK for wide character. + -- Wide_Wide_Character literals must always be defined, since the set + -- of wide wide character literals is complete, i.e. if a character + -- literal is accepted by the parser, then it is OK for wide wide + -- character (out of range character literals are rejected). - if Root_Type (B_Typ) = Standard_Wide_Character then + if Root_Type (B_Typ) = Standard_Wide_Wide_Character then return; -- Always accept character literal for type Any_Character, which @@ -3372,10 +4028,24 @@ package body Sem_Res is -- the literal is in range elsif Root_Type (B_Typ) = Standard_Character then - if In_Character_Range (Char_Literal_Value (N)) then + if In_Character_Range (UI_To_CC (Char_Literal_Value (N))) then return; end if; + -- For Standard.Wide_Character or a type derived from it, check + -- that the literal is in range + + elsif Root_Type (B_Typ) = Standard_Wide_Character then + if In_Wide_Character_Range (UI_To_CC (Char_Literal_Value (N))) then + return; + end if; + + -- For Standard.Wide_Wide_Character or a type derived from it, we + -- know the literal is in range, since the parser checked! + + elsif Root_Type (B_Typ) = Standard_Wide_Wide_Character then + return; + -- If the entity is already set, this has already been resolved in -- a generic context, or comes from expansion. Nothing else to do. @@ -3387,7 +4057,6 @@ package body Sem_Res is else C := Current_Entity (N); - while Present (C) loop if Etype (C) = B_Typ then Set_Entity_With_Style_Check (N, C); @@ -3405,7 +4074,6 @@ package body Sem_Res is Error_Msg_NE ("character not defined for }", N, First_Subtype (B_Typ)); - end Resolve_Character_Literal; --------------------------- @@ -3413,7 +4081,9 @@ package body Sem_Res is --------------------------- -- Context requires a boolean type, and plays no role in resolution. - -- Processing identical to that for equality operators. + -- Processing identical to that for equality operators. The result + -- type is the base type, which matters when pathological subtypes of + -- booleans with limited ranges are used. procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id) is L : constant Node_Id := Left_Opnd (N); @@ -3428,6 +4098,7 @@ package body Sem_Res is if Scope (Entity (N)) /= Standard_Standard then T := Etype (First_Entity (Entity (N))); + else T := Find_Unique_Type (L, R); @@ -3436,11 +4107,10 @@ package body Sem_Res is end if; end if; - Set_Etype (N, Typ); + Set_Etype (N, Base_Type (Typ)); Generate_Reference (T, N, ' '); if T /= Any_Type then - if T = Any_String or else T = Any_Composite or else T = Any_Character @@ -3455,22 +4125,15 @@ package body Sem_Res is return; else - if Comes_From_Source (N) - and then Has_Unchecked_Union (T) - then - Error_Msg_N - ("cannot compare Unchecked_Union values", N); - end if; - Resolve (L, T); Resolve (R, T); Check_Unset_Reference (L); Check_Unset_Reference (R); - Generate_Operator_Reference (N); + Generate_Operator_Reference (N, T); Eval_Relational_Op (N); + Check_Direct_Boolean_Op (N); end if; end if; - end Resolve_Comparison_Op; ------------------------------------ @@ -3563,8 +4226,8 @@ package body Sem_Res is -- away if either bounds of R are a Constraint_Error. declare - L : Node_Id := Low_Bound (R); - H : Node_Id := High_Bound (R); + L : constant Node_Id := Low_Bound (R); + H : constant Node_Id := High_Bound (R); begin if Nkind (L) = N_Raise_Constraint_Error then @@ -3592,6 +4255,13 @@ package body Sem_Res is E : constant Entity_Id := Entity (N); begin + -- If garbage from errors, set to Any_Type and return + + if No (E) and then Total_Errors_Detected /= 0 then + Set_Etype (N, Any_Type); + return; + end if; + -- Replace named numbers by corresponding literals. Note that this is -- the one case where Resolve_Entity_Name must reset the Etype, since -- it is currently marked as universal. @@ -3616,7 +4286,7 @@ package body Sem_Res is null; else Error_Msg_N - ("Invalid use of subtype mark in expression or call", N); + ("invalid use of subtype mark in expression or call", N); end if; -- Check discriminant use if entity is discriminant in current scope, @@ -3636,7 +4306,7 @@ package body Sem_Res is Error_Msg_N ("illegal use of generic function", N); elsif Ekind (E) = E_Out_Parameter - and then Ada_83 + and then Ada_Version = Ada_83 and then (Nkind (Parent (N)) in N_Op or else (Nkind (Parent (N)) = N_Assignment_Statement and then N = Expression (Parent (N))) @@ -3698,10 +4368,10 @@ package body Sem_Res is ----------------------- function Actual_Index_Type (E : Entity_Id) return Entity_Id is - Typ : Entity_Id := Entry_Index_Type (E); - Tsk : Entity_Id := Scope (E); - Lo : Node_Id := Type_Low_Bound (Typ); - Hi : Node_Id := Type_High_Bound (Typ); + Typ : constant Entity_Id := Entry_Index_Type (E); + Tsk : constant Entity_Id := Scope (E); + Lo : constant Node_Id := Type_Low_Bound (Typ); + Hi : constant Node_Id := Type_High_Bound (Typ); New_T : Entity_Id; function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id; @@ -3717,7 +4387,7 @@ package body Sem_Res is ----------------------------- function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is - Typ : Entity_Id := Etype (Bound); + Typ : constant Entity_Id := Etype (Bound); Ref : Node_Id; begin @@ -3812,7 +4482,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; @@ -3845,16 +4514,14 @@ package body Sem_Res is -- protected type. declare - Pref : Node_Id := Prefix (Entry_Name); + Pref : constant Node_Id := Prefix (Entry_Name); + Ent : constant Entity_Id := Entity (Selector_Name (Entry_Name)); I : Interp_Index; It : Interp; - Ent : Entity_Id := Entity (Selector_Name (Entry_Name)); begin Get_First_Interp (Pref, I, It); - while Present (It.Typ) loop - if Scope (Ent) = It.Typ then Set_Etype (Pref, It.Typ); exit; @@ -3866,13 +4533,11 @@ package body Sem_Res is end if; if Nkind (Entry_Name) = N_Selected_Component then - Resolve (Prefix (Entry_Name), Etype (Prefix (Entry_Name))); + Resolve (Prefix (Entry_Name)); else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component); Nam := Entity (Selector_Name (Prefix (Entry_Name))); - Resolve (Prefix (Prefix (Entry_Name)), - Etype (Prefix (Prefix (Entry_Name)))); - + Resolve (Prefix (Prefix (Entry_Name))); Index := First (Expressions (Entry_Name)); Resolve (Index, Entry_Index_Type (Nam)); @@ -3885,7 +4550,6 @@ package body Sem_Res is Apply_Range_Check (Index, Actual_Index_Type (Nam)); end if; end if; - end Resolve_Entry; ------------------------ @@ -3903,6 +4567,11 @@ 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. + + Kill_All_Checks; + -- Processing of the name is similar for entry calls and protected -- operation calls. Once the entity is determined, we can complete -- the resolution of the actuals. @@ -3921,9 +4590,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); @@ -3940,7 +4607,7 @@ package body Sem_Res is if Nkind (Entry_Name) = N_Selected_Component then - -- Simple entry call. + -- Simple entry call Nam := Entity (Selector_Name (Entry_Name)); Obj := Prefix (Entry_Name); @@ -3948,13 +4615,21 @@ package body Sem_Res is else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component); - -- Call to member of entry family. + -- Call to member of entry family Nam := Entity (Selector_Name (Prefix (Entry_Name))); Obj := Prefix (Prefix (Entry_Name)); Was_Over := Is_Overloaded (Selector_Name (Prefix (Entry_Name))); end if; + -- We cannot in general check the maximum depth of protected entry + -- calls at compile time. But we can tell that any protected entry + -- call at all violates a specified nesting depth of zero. + + if Is_Protected_Type (Scope (Nam)) then + Check_Restriction (Max_Entry_Queue_Length, N); + end if; + -- Use context type to disambiguate a protected function that can be -- called without actuals and that returns an array type, and where -- the argument list may be an indexing of the returned value. @@ -3994,11 +4669,13 @@ package body Sem_Res is end if; -- The operation name may have been overloaded. Order the actuals - -- according to the formals of the resolved entity. + -- according to the formals of the resolved entity, and set the + -- return type to that of the operation. if Was_Over then Normalize_Actuals (N, Nam, False, Norm_OK); pragma Assert (Norm_OK); + Set_Etype (N, Etype (Nam)); end if; Resolve_Actuals (N, Nam); @@ -4014,7 +4691,6 @@ package body Sem_Res is -- call where an entry call is expected. if Ekind (Nam) = E_Procedure then - if Nkind (Parent (N)) = N_Entry_Call_Alternative and then N = Entry_Call_Statement (Parent (N)) then @@ -4028,7 +4704,7 @@ package body Sem_Res is elsif Ekind (Scope (Nam)) = E_Task_Type and then not In_Open_Scopes (Scope (Nam)) then - Error_Msg_N ("Task has no entry with this name", Entry_Name); + Error_Msg_N ("task has no entry with this name", Entry_Name); end if; end if; @@ -4066,7 +4742,7 @@ 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)) @@ -4074,7 +4750,6 @@ package body Sem_Res is Establish_Transient_Scope (N, Sec_Stack => not Functions_Return_By_DSP_On_Target); end if; - end Resolve_Entry_Call; ------------------------- @@ -4107,7 +4782,7 @@ 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 @@ -4120,11 +4795,10 @@ package body Sem_Res is 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 @@ -4153,12 +4827,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 @@ -4180,18 +4852,21 @@ package body Sem_Res is end if; end if; - if Comes_From_Source (N) - and then Has_Unchecked_Union (T) + Resolve (L, T); + Resolve (R, T); + + 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 - ("cannot compare Unchecked_Union values", N); + Error_Msg_N ("comparison with True is redundant?", R); end if; - Resolve (L, T); - Resolve (R, T); Check_Unset_Reference (L); Check_Unset_Reference (R); - Generate_Operator_Reference (N); + Generate_Operator_Reference (N, T); -- If this is an inequality, it may be the implicit inequality -- created for a user-defined operation, in which case the corres- @@ -4210,6 +4885,8 @@ package body Sem_Res is then Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N)); end if; + + Check_Direct_Boolean_Op (N); end if; end Resolve_Equality_Op; @@ -4218,53 +4895,111 @@ package body Sem_Res is ---------------------------------- procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id) is - P : constant Node_Id := Prefix (N); - I : Interp_Index; - It : Interp; + Loc : constant Source_Ptr := Sloc (N); + New_N : Node_Id; + P : constant Node_Id := Prefix (N); + I : Interp_Index; + It : Interp; begin - -- Now that we know the type, check that this is not a - -- dereference of an uncompleted type. Note that this - -- is not entirely correct, because dereferences of - -- private types are legal in default expressions. - -- This consideration also applies to similar checks - -- for allocators, qualified expressions, and type - -- conversions. ??? + -- 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; + + -- 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. - Check_Fully_Declared (Typ, N); + elsif Ada_Version >= Ada_05 + and then Is_Entity_Name (Prefix (N)) + and then Ekind (Directly_Designated_Type (Etype (Prefix (N)))) + = E_Incomplete_Type + and then Is_Tagged_Type (Directly_Designated_Type (Etype (Prefix (N)))) + then + null; + else + Check_Fully_Declared (Typ, N); + end if; if Is_Overloaded (P) then - -- Use the context type to select the prefix that has the - -- correct designated type. + -- Use the context type to select the prefix that has the correct + -- designated type. Get_First_Interp (P, I, It); while Present (It.Typ) loop exit when Is_Access_Type (It.Typ) and then Covers (Typ, Designated_Type (It.Typ)); - Get_Next_Interp (I, It); end loop; - Resolve (P, It.Typ); + if Present (It.Typ) then + Resolve (P, It.Typ); + else + -- If no interpretation covers the designated type of the prefix, + -- this is the pathological case where not all implementations of + -- the prefix allow the interpretation of the node as a call. Now + -- that the expected type is known, Remove other interpretations + -- from prefix, rewrite it as a call, and resolve again, so that + -- the proper call node is generated. + + Get_First_Interp (P, I, It); + while Present (It.Typ) loop + if Ekind (It.Typ) /= E_Access_Subprogram_Type then + Remove_Interp (I); + end if; + + Get_Next_Interp (I, It); + end loop; + + New_N := + Make_Function_Call (Loc, + Name => + Make_Explicit_Dereference (Loc, + Prefix => P), + Parameter_Associations => New_List); + + Save_Interps (N, New_N); + Rewrite (N, New_N); + Analyze_And_Resolve (N, Typ); + return; + end if; + Set_Etype (N, Designated_Type (It.Typ)); else - Resolve (P, Etype (P)); + Resolve (P); end if; if Is_Access_Type (Etype (P)) then Apply_Access_Check (N); end if; - -- If the designated type is a packed unconstrained array type, - -- and the explicit dereference is not in the context of an - -- attribute reference, then we must compute and set the actual - -- subtype, since it is needed by Gigi. The reason we exclude - -- the attribute case is that this is handled fine by Gigi, and - -- in fact we use such attributes to build the actual subtype. - -- We also exclude generated code (which builds actual subtypes - -- directly if they are needed). + -- If the designated type is a packed unconstrained array type, and the + -- explicit dereference is not in the context of an attribute reference, + -- then we must compute and set the actual subtype, since it is needed + -- by Gigi. The reason we exclude the attribute case is that this is + -- handled fine by Gigi, and in fact we use such attributes to build the + -- actual subtype. We also exclude generated code (which builds actual + -- subtypes directly if they are needed). if Is_Array_Type (Etype (N)) and then Is_Packed (Etype (N)) @@ -4275,9 +5010,9 @@ 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: there is no Eval processing required for an explicit deference, + -- because the type is known to be an allocators, and allocator + -- expressions can never be static. end Resolve_Explicit_Dereference; @@ -4294,8 +5029,8 @@ package body Sem_Res is begin if Is_Overloaded (Name) then - -- Use the context type to select the prefix that yields the - -- correct component type. + -- Use the context type to select the prefix that yields the correct + -- component type. declare I : Interp_Index; @@ -4306,9 +5041,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, Component_Type (It.Typ))) or else (Is_Access_Type (It.Typ) @@ -4356,17 +5089,17 @@ package body Sem_Res is Array_Type := Designated_Type (Array_Type); end if; - -- If name was overloaded, set component type correctly now. + -- If name was overloaded, set component type correctly now Set_Etype (N, Component_Type (Array_Type)); Index := First_Index (Array_Type); Expr := First (Expressions (N)); - -- The prefix may have resolved to a string literal, in which case - -- its etype has a special representation. This is only possible - -- currently if the prefix is a static concatenation, written in - -- functional notation. + -- The prefix may have resolved to a string literal, in which case its + -- etype has a special representation. This is only possible currently + -- if the prefix is a static concatenation, written in functional + -- notation. if Ekind (Array_Type) = E_String_Literal_Subtype then Resolve (Expr, Standard_Positive); @@ -4388,7 +5121,6 @@ package body Sem_Res is end if; Eval_Indexed_Component (N); - end Resolve_Indexed_Component; ----------------------------- @@ -4401,36 +5133,117 @@ package body Sem_Res is Eval_Integer_Literal (N); end Resolve_Integer_Literal; - --------------------------------- - -- Resolve_Intrinsic_Operator -- - --------------------------------- + -------------------------------- + -- Resolve_Intrinsic_Operator -- + -------------------------------- procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id) is - Op : Entity_Id; - Arg1 : Node_Id := Left_Opnd (N); - Arg2 : Node_Id := Right_Opnd (N); + Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ)); + Op : Entity_Id; + Arg1 : Node_Id; + Arg2 : Node_Id; begin Op := Entity (N); - while Scope (Op) /= Standard_Standard loop Op := Homonym (Op); pragma Assert (Present (Op)); end loop; Set_Entity (N, Op); + Set_Is_Overloaded (N, False); - if Typ /= Etype (Arg1) or else Typ = Etype (Arg2) then - Rewrite (Left_Opnd (N), Convert_To (Typ, Arg1)); - Rewrite (Right_Opnd (N), Convert_To (Typ, Arg2)); + -- If the operand type is private, rewrite with suitable conversions on + -- the operands and the result, to expose the proper underlying numeric + -- type. - Analyze (Left_Opnd (N)); - Analyze (Right_Opnd (N)); - end if; + if Is_Private_Type (Typ) then + Arg1 := Unchecked_Convert_To (Btyp, Left_Opnd (N)); - Resolve_Arithmetic_Op (N, Typ); + if Nkind (N) = N_Op_Expon then + Arg2 := Unchecked_Convert_To (Standard_Integer, Right_Opnd (N)); + else + Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N)); + end if; + + Save_Interps (Left_Opnd (N), Expression (Arg1)); + Save_Interps (Right_Opnd (N), Expression (Arg2)); + + Set_Left_Opnd (N, Arg1); + Set_Right_Opnd (N, Arg2); + + Set_Etype (N, Btyp); + Rewrite (N, Unchecked_Convert_To (Typ, N)); + Resolve (N, Typ); + + elsif Typ /= Etype (Left_Opnd (N)) + or else Typ /= Etype (Right_Opnd (N)) + then + -- Add explicit conversion where needed, and save interpretations + -- in case operands are overloaded. + + Arg1 := Convert_To (Typ, Left_Opnd (N)); + Arg2 := Convert_To (Typ, Right_Opnd (N)); + + if Nkind (Arg1) = N_Type_Conversion then + Save_Interps (Left_Opnd (N), Expression (Arg1)); + else + Save_Interps (Left_Opnd (N), Arg1); + end if; + + if Nkind (Arg2) = N_Type_Conversion then + Save_Interps (Right_Opnd (N), Expression (Arg2)); + else + Save_Interps (Right_Opnd (N), Arg2); + end if; + + Rewrite (Left_Opnd (N), Arg1); + Rewrite (Right_Opnd (N), Arg2); + Analyze (Arg1); + Analyze (Arg2); + Resolve_Arithmetic_Op (N, Typ); + + else + Resolve_Arithmetic_Op (N, Typ); + end if; end Resolve_Intrinsic_Operator; + -------------------------------------- + -- Resolve_Intrinsic_Unary_Operator -- + -------------------------------------- + + procedure Resolve_Intrinsic_Unary_Operator + (N : Node_Id; + Typ : Entity_Id) + is + Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ)); + Op : Entity_Id; + Arg2 : Node_Id; + + begin + Op := Entity (N); + while Scope (Op) /= Standard_Standard loop + Op := Homonym (Op); + pragma Assert (Present (Op)); + end loop; + + Set_Entity (N, Op); + + if Is_Private_Type (Typ) then + Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N)); + Save_Interps (Right_Opnd (N), Expression (Arg2)); + + Set_Right_Opnd (N, Arg2); + + Set_Etype (N, Btyp); + Rewrite (N, Unchecked_Convert_To (Typ, N)); + Resolve (N, Typ); + + else + Resolve_Unary_Op (N, Typ); + end if; + end Resolve_Intrinsic_Unary_Operator; + ------------------------ -- Resolve_Logical_Op -- ------------------------ @@ -4439,9 +5252,9 @@ package body Sem_Res is B_Typ : Entity_Id; begin - -- Predefined operations on scalar types yield the base type. On - -- the other hand, logical operations on arrays yield the type of - -- the arguments (and the context). + -- Predefined operations on scalar types yield the base type. On the + -- other hand, logical operations on arrays yield the type of the + -- arguments (and the context). if Is_Array_Type (Typ) then B_Typ := Typ; @@ -4465,6 +5278,11 @@ package body Sem_Res is ("no modular type available in this context", N); Set_Etype (N, Any_Type); return; + elsif Is_Modular_Integer_Type (Typ) + and then Etype (Left_Opnd (N)) = Universal_Integer + and then Etype (Right_Opnd (N)) = Universal_Integer + then + Check_For_Visible_Operator (N, B_Typ); end if; Resolve (Left_Opnd (N), B_Typ); @@ -4474,8 +5292,9 @@ package body Sem_Res is Check_Unset_Reference (Right_Opnd (N)); Set_Etype (N, B_Typ); - Generate_Operator_Reference (N); + Generate_Operator_Reference (N, B_Typ); Eval_Logical_Op (N); + Check_Direct_Boolean_Op (N); end Resolve_Logical_Op; --------------------------- @@ -4487,6 +5306,8 @@ package body Sem_Res is -- rule for universal types applies. procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id) is + pragma Warnings (Off, Typ); + L : constant Node_Id := Left_Opnd (N); R : constant Node_Id := Right_Opnd (N); T : Entity_Id; @@ -4503,6 +5324,28 @@ package body Sem_Res is and then Is_Overloaded (L) then T := Etype (R); + + -- Ada 2005 (AI-251): Give support to the following case: + + -- type I is interface; + -- type T is tagged ... + + -- function Test (O : in 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; @@ -4532,11 +5375,13 @@ package body Sem_Res is procedure Resolve_Null (N : Node_Id; Typ : Entity_Id) is begin - -- For now allow circumvention of the restriction against - -- anonymous null access values via a debug switch to allow - -- for easier transition. + -- Handle restriction against anonymous null access values This + -- restriction can be turned off using -gnatdh. + + -- Ada 2005 (AI-231): Remove restriction - if not Debug_Flag_J + if Ada_Version < Ada_05 + and then not Debug_Flag_J and then Ekind (Typ) = E_Anonymous_Access_Type and then Comes_From_Source (N) then @@ -4569,7 +5414,7 @@ package body Sem_Res is return; end if; - -- The null literal takes its type from the context. + -- The null literal takes its type from the context Set_Etype (N, Typ); end Resolve_Null; @@ -4632,9 +5477,7 @@ package body Sem_Res is begin Get_First_Interp (Arg, I, It); - while Present (It.Nam) loop - if Base_Type (Etype (It.Nam)) = Base_Type (Typ) or else Base_Type (Etype (It.Nam)) = Base_Type (Component_Type (Typ)) @@ -4650,6 +5493,10 @@ package body Sem_Res is Resolve (Arg, Component_Type (Typ)); + if Nkind (Arg) = N_String_Literal then + Set_Etype (Arg, Component_Type (Typ)); + end if; + if Arg = Left_Opnd (N) then Set_Is_Component_Left_Opnd (N); else @@ -4671,11 +5518,12 @@ package body Sem_Res is if Is_Limited_Composite (Btyp) then Error_Msg_N ("concatenation not available for limited array", N); + Explain_Limited_Type (Btyp, N); end if; - -- If the operands are themselves concatenations, resolve them as - -- such directly. This removes several layers of recursion and allows - -- GNAT to handle larger multiple concatenations. + -- If the operands are themselves concatenations, resolve them as such + -- directly. This removes several layers of recursion and allows GNAT to + -- handle larger multiple concatenations. if Nkind (Op1) = N_Op_Concat and then not Is_Array_Type (Component_Type (Typ)) @@ -4697,7 +5545,7 @@ package body Sem_Res is (Op2, Is_Component_Right_Opnd (N)); end if; - Generate_Operator_Reference (N); + Generate_Operator_Reference (N, Typ); if Is_String_Type (Typ) then Eval_Concatenation (N); @@ -4724,14 +5572,23 @@ package body Sem_Res is begin -- Catch attempts to do fixed-point exponentation with universal - -- operands, which is a case where the illegality is not caught - -- during normal operator analysis. + -- operands, which is a case where the illegality is not caught during + -- normal operator analysis. if Is_Fixed_Point_Type (Typ) and then Comes_From_Source (N) then Error_Msg_N ("exponentiation not available for fixed point", N); return; end if; + if Comes_From_Source (N) + and then Ekind (Entity (N)) = E_Function + and then Is_Imported (Entity (N)) + and then Is_Intrinsic_Subprogram (Entity (N)) + then + Resolve_Intrinsic_Operator (N, Typ); + return; + end if; + if Etype (Left_Opnd (N)) = Universal_Integer or else Etype (Left_Opnd (N)) = Universal_Real then @@ -4748,7 +5605,7 @@ package body Sem_Res is Check_Unset_Reference (Right_Opnd (N)); Set_Etype (N, B_Typ); - Generate_Operator_Reference (N); + Generate_Operator_Reference (N, B_Typ); Eval_Op_Expon (N); -- Set overflow checking bit. Much cleverer code needed here eventually @@ -4757,10 +5614,9 @@ package body Sem_Res is if Nkind (N) in N_Op then if not Overflow_Checks_Suppressed (Etype (N)) then - Set_Do_Overflow_Check (N, True); + Enable_Overflow_Check (N); end if; end if; - end Resolve_Op_Expon; -------------------- @@ -4808,9 +5664,9 @@ package body Sem_Res is -- Start of processing for Resolve_Op_Not begin - -- Predefined operations on scalar types yield the base type. On - -- the other hand, logical operations on arrays yield the type of - -- the arguments (and the context). + -- Predefined operations on scalar types yield the base type. On the + -- other hand, logical operations on arrays yield the type of the + -- arguments (and the context). if Is_Array_Type (Typ) then B_Typ := Typ; @@ -4823,9 +5679,7 @@ package body Sem_Res is Set_Etype (N, Any_Type); return; - elsif (Typ = Universal_Integer - or else Typ = Any_Modular) - then + elsif Typ = Universal_Integer or else Typ = Any_Modular then if Parent_Is_Boolean then Error_Msg_N ("operand of not must be enclosed in parentheses", @@ -4848,7 +5702,7 @@ package body Sem_Res is Resolve (Right_Opnd (N), B_Typ); Check_Unset_Reference (Right_Opnd (N)); Set_Etype (N, B_Typ); - Generate_Operator_Reference (N); + Generate_Operator_Reference (N, B_Typ); Eval_Op_Not (N); end if; end Resolve_Op_Not; @@ -4860,6 +5714,9 @@ package body Sem_Res is -- Nothing to be done, all resolved already procedure Resolve_Operator_Symbol (N : Node_Id; Typ : Entity_Id) is + pragma Warnings (Off, N); + pragma Warnings (Off, Typ); + begin null; end Resolve_Operator_Symbol; @@ -4869,6 +5726,8 @@ package body Sem_Res is ---------------------------------- procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id) is + pragma Warnings (Off, Typ); + Target_Typ : constant Entity_Id := Entity (Subtype_Mark (N)); Expr : constant Node_Id := Expression (N); @@ -4876,9 +5735,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); @@ -4914,16 +5780,31 @@ package body Sem_Res is Check_Unset_Reference (H); -- We have to check the bounds for being within the base range as - -- required for a non-static context. Normally this is automatic - -- and done as part of evaluating expressions, but the N_Range - -- node is an exception, since in GNAT we consider this node to - -- be a subexpression, even though in Ada it is not. The circuit - -- in Sem_Eval could check for this, but that would put the test - -- on the main evaluation path for expressions. + -- required for a non-static context. Normally this is automatic and + -- done as part of evaluating expressions, but the N_Range node is an + -- exception, since in GNAT we consider this node to be a subexpression, + -- even though in Ada it is not. The circuit in Sem_Eval could check for + -- this, but that would put the test on the main evaluation path for + -- expressions. Check_Non_Static_Context (L); Check_Non_Static_Context (H); + -- If bounds are static, constant-fold them, so size computations + -- are identical between front-end and back-end. Do not perform this + -- transformation while analyzing generic units, as type information + -- would then be lost when reanalyzing the constant node in the + -- instance. + + if Is_Discrete_Type (Typ) and then Expander_Active then + if Is_OK_Static_Expression (L) then + Fold_Uint (L, Expr_Value (L), Is_Static_Expression (L)); + end if; + + if Is_OK_Static_Expression (H) then + Fold_Uint (H, Expr_Value (H), Is_Static_Expression (H)); + end if; + end if; end Resolve_Range; -------------------------- @@ -4965,6 +5846,16 @@ package body Sem_Res is Error_Msg_N ("value has extraneous low order digits", N); end if; + -- Generate a warning if literal from source + + if Is_Static_Expression (N) + and then Warn_On_Bad_Fixed_Value + then + Error_Msg_N + ("static fixed-point value is not a multiple of Small?", + N); + end if; + -- Replace literal by a value that is the exact representation -- of a value of the type, i.e. a multiple of the small value, -- by truncation, since Machine_Rounds is false for all GNAT @@ -5008,11 +5899,11 @@ package body Sem_Res is -- If we are taking the reference of a volatile entity, then treat -- it as a potential modification of this entity. This is much too - -- conservative, but is neccessary because remove side effects can + -- conservative, but is necessary because remove side effects can -- result in transformations of normal assignments into reference -- sequences that otherwise fail to notice the modification. - if Is_Entity_Name (P) and then Is_Volatile (Entity (P)) then + if Is_Entity_Name (P) and then Treat_As_Volatile (Entity (P)) then Note_Possible_Modification (P); end if; end Resolve_Reference; @@ -5033,6 +5924,25 @@ package body Sem_Res is It1 : Interp; Found : Boolean; + function Init_Component return Boolean; + -- Check whether this is the initialization of a component within an + -- init proc (by assignment or call to another init proc). If true, + -- there is no need for a discriminant check. + + -------------------- + -- Init_Component -- + -------------------- + + function Init_Component return Boolean is + begin + return Inside_Init_Proc + and then Nkind (Prefix (N)) = N_Identifier + and then Chars (Prefix (N)) = Name_uInit + and then Nkind (Parent (Parent (N))) = N_Case_Statement_Alternative; + end Init_Component; + + -- Start of processing for Resolve_Selected_Component + begin if Is_Overloaded (P) then @@ -5051,9 +5961,7 @@ package body Sem_Res is if Is_Record_Type (T) then Comp := First_Entity (T); - while Present (Comp) loop - if Chars (Comp) = Chars (S) and then Covers (Etype (Comp), Typ) then @@ -5081,7 +5989,6 @@ package body Sem_Res is -- Find the component with the right name. Comp1 := First_Entity (It1.Typ); - while Present (Comp1) and then Chars (Comp1) /= Chars (S) loop @@ -5100,7 +6007,6 @@ package body Sem_Res is end if; Get_Next_Interp (I, It); - end loop Search; Resolve (P, It1.Typ); @@ -5108,26 +6014,31 @@ package body Sem_Res is Set_Entity (S, Comp1); else - -- Resolve prefix with its type. + -- Resolve prefix with its type Resolve (P, T); end if; - -- Deal with access type case + -- 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 - Apply_Access_Check (N); T := Designated_Type (Etype (P)); else T := Etype (P); end if; if Has_Discriminants (T) + and then (Ekind (Entity (S)) = E_Component + or else + Ekind (Entity (S)) = E_Discriminant) and then Present (Original_Record_Component (Entity (S))) and then Ekind (Original_Record_Component (Entity (S))) = E_Component and then Present (Discriminant_Checking_Func (Original_Record_Component (Entity (S)))) and then not Discriminant_Checks_Suppressed (T) + and then not Init_Component then Set_Do_Discriminant_Check (N); end if; @@ -5142,6 +6053,7 @@ package body Sem_Res is if Nkind (P) = N_Type_Conversion and then Ekind (Entity (S)) = E_Discriminant + and then Is_Discrete_Type (Typ) then Set_Etype (N, Base_Type (Typ)); end if; @@ -5171,7 +6083,7 @@ package body Sem_Res is Check_Unset_Reference (R); Set_Etype (N, B_Typ); - Generate_Operator_Reference (N); + Generate_Operator_Reference (N, B_Typ); Eval_Shift (N); end Resolve_Shift; @@ -5220,9 +6132,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) @@ -5262,6 +6172,26 @@ 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 not Is_Constrained (Array_Type) then + Remove_Side_Effects (Prefix (N)); + + declare + Obj : constant Node_Id := + Make_Explicit_Dereference (Sloc (N), + Prefix => New_Copy_Tree (Prefix (N))); + begin + Set_Etype (Obj, Array_Type); + Set_Parent (Obj, Parent (N)); + Array_Type := Get_Actual_Subtype (Obj); + end; + end if; + elsif Is_Entity_Name (Name) or else (Nkind (Name) = N_Function_Call and then not Is_Constrained (Etype (Name))) @@ -5274,7 +6204,7 @@ package body Sem_Res is Set_Etype (N, Array_Type); -- If the range is specified by a subtype mark, no resolution - -- is necessary. + -- is necessary. Else resolve the bounds, and apply needed checks. if not Is_Entity_Name (Drange) then Index := First_Index (Array_Type); @@ -5287,7 +6217,6 @@ package body Sem_Res is Set_Slice_Subtype (N); Eval_Slice (N); - end Resolve_Slice; ---------------------------- @@ -5323,7 +6252,8 @@ package body Sem_Res is or else Nkind (Parent (N)) /= N_Op_Concat or else (N /= Left_Opnd (Parent (N)) and then N /= Right_Opnd (Parent (N))) - or else (Typ = Standard_Wide_String + or else ((Typ = Standard_Wide_String + or else Typ = Standard_Wide_Wide_String) and then Nkind (Original_Node (N)) /= N_String_Literal); -- If the resolving type is itself a string literal subtype, we @@ -5383,21 +6313,21 @@ package body Sem_Res is elsif Is_Bit_Packed_Array (Typ) then null; - -- Deal with cases of Wide_String and String + -- Deal with cases of Wide_Wide_String, Wide_String, and String else - -- For Standard.Wide_String, or any other type whose component - -- type is Standard.Wide_Character, we know that all the + -- For Standard.Wide_Wide_String, or any other type whose component + -- type is Standard.Wide_Wide_Character, we know that all the -- characters in the string must be acceptable, since the parser -- accepted the characters as valid character literals. - if R_Typ = Standard_Wide_Character then + 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 String. + -- 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 @@ -5414,7 +6344,36 @@ package body Sem_Res is -- a token, right under the offending wide character. Error_Msg - ("literal out of range of type Character", + ("literal out of range of type Standard.Character", + Source_Ptr (Int (Loc) + J)); + return; + end if; + end loop; + + -- For the case of Standard.Wide_String, or any other type whose + -- component type is Standard.Wide_Character, we must make sure that + -- there are no wide characters in the string, i.e. that it is + -- entirely composed of characters in range of type Wide_Character. + + -- If the string literal is the result of a static concatenation, + -- the test has already been performed on the components, and need + -- not be repeated. + + elsif R_Typ = Standard_Wide_Character + and then Nkind (Original_Node (N)) /= N_Op_Concat + then + for J in 1 .. Strlen loop + if not In_Wide_Character_Range (Get_String_Char (Str, J)) then + + -- If we are out of range, post error. This is one of the + -- very few places that we place the flag in the middle of + -- a token, right under the offending wide character. + + -- This is not quite right, because characters in general + -- will take more than one character position ??? + + Error_Msg + ("literal out of range of type Standard.Wide_Character", Source_Ptr (Int (Loc) + J)); return; end if; @@ -5422,11 +6381,10 @@ package body Sem_Res is -- If the root type is not a standard character, then we will convert -- the string into an aggregate and will let the aggregate code do - -- the checking. + -- the checking. Standard Wide_Wide_Character is also OK here. else null; - end if; -- See if the component type of the array corresponding to the @@ -5436,8 +6394,9 @@ package body Sem_Res is -- the corresponding character aggregate and let the aggregate -- code do the checking. - if R_Typ = Standard_Wide_Character - or else R_Typ = Standard_Character + if R_Typ = Standard_Character + or else R_Typ = Standard_Wide_Character + or else R_Typ = Standard_Wide_Wide_Character then -- Check for the case of full range, where we are definitely OK @@ -5466,7 +6425,7 @@ package body Sem_Res is or else Char_Val > Expr_Value (Comp_Typ_Hi) then Apply_Compile_Time_Constraint_Error - (N, "character out of range?", + (N, "character out of range?", CE_Range_Check_Failed, Loc => Source_Ptr (Int (Loc) + J)); end if; end loop; @@ -5482,7 +6441,7 @@ package body Sem_Res is -- heavy artillery for this situation, but it is hard work to avoid. declare - Lits : List_Id := New_List; + Lits : constant List_Id := New_List; P : Source_Ptr := Loc + 1; C : Char_Code; @@ -5496,7 +6455,9 @@ package body Sem_Res is Set_Character_Literal_Name (C); Append_To (Lits, - Make_Character_Literal (P, Name_Find, C)); + Make_Character_Literal (P, + Chars => Name_Find, + Char_Literal_Value => UI_From_CC (C))); if In_Character_Range (C) then P := P + 1; @@ -5532,11 +6493,13 @@ package body Sem_Res is ----------------------------- procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id) is - Target_Type : constant Entity_Id := Etype (N); - Conv_OK : constant Boolean := Conversion_OK (N); + Conv_OK : constant Boolean := Conversion_OK (N); + Target_Type : Entity_Id := Etype (N); Operand : Node_Id; Opnd_Type : Entity_Id; Rop : Node_Id; + Orig_N : Node_Id; + Orig_T : Node_Id; begin Operand := Expression (N); @@ -5561,12 +6524,18 @@ package body Sem_Res is and then (Etype (Right_Opnd (Operand)) = Universal_Real or else Etype (Left_Opnd (Operand)) = Universal_Real) then + -- Return if expression is ambiguous + if Unique_Fixed_Point_Type (N) = Any_Type then - return; -- expression is ambiguous. + return; + + -- If nothing else, the available fixed type is Duration + else Set_Etype (Operand, Standard_Duration); end if; + -- Resolve the real operand with largest available precision if Etype (Right_Opnd (Operand)) = Universal_Real then Rop := New_Copy_Tree (Right_Opnd (Operand)); else @@ -5575,7 +6544,12 @@ package body Sem_Res is Resolve (Rop, Standard_Long_Long_Float); - if Realval (Rop) /= Ureal_0 + -- If the operand is a literal (it could be a non-static and + -- illegal exponentiation) check whether the use of Duration + -- is potentially inaccurate. + + if Nkind (Rop) = N_Real_Literal + and then Realval (Rop) /= Ureal_0 and then abs (Realval (Rop)) < Delta_Value (Standard_Duration) then Error_Msg_N ("universal real operand can only be interpreted?", @@ -5583,6 +6557,12 @@ package body Sem_Res is Error_Msg_N ("\as Duration, and will lose precision?", Rop); end if; + elsif Is_Numeric_Type (Typ) + and then Nkind (Operand) in N_Op + and then Unique_Fixed_Point_Type (N) /= Any_Type + then + Set_Etype (Operand, Standard_Duration); + else Error_Msg_N ("invalid context for mixed mode operation", N); Set_Etype (Operand, Any_Type); @@ -5591,7 +6571,7 @@ package body Sem_Res is end if; Opnd_Type := Etype (Operand); - Resolve (Operand, Opnd_Type); + Resolve (Operand); -- Note: we do the Eval_Type_Conversion call before applying the -- required checks for a subtype conversion. This is important, @@ -5619,16 +6599,82 @@ package body Sem_Res is end if; -- Issue warning for conversion of simple object to its own type + -- We have to test the original nodes, since they may have been + -- rewritten by various optimizations. + + Orig_N := Original_Node (N); if Warn_On_Redundant_Constructs - and then Comes_From_Source (N) - and then Nkind (N) = N_Type_Conversion - and then Is_Entity_Name (Expression (N)) - and then Etype (Entity (Expression (N))) = Target_Type + and then Comes_From_Source (Orig_N) + and then Nkind (Orig_N) = N_Type_Conversion + and then not In_Instance then - Error_Msg_NE - ("?useless conversion, & has this type", - N, Entity (Expression (N))); + Orig_N := Original_Node (Expression (Orig_N)); + Orig_T := Target_Type; + + -- If the node is part of a larger expression, the Target_Type + -- may not be the original type of the node if the context is a + -- condition. Recover original type to see if conversion is needed. + + if Is_Boolean_Type (Orig_T) + and then Nkind (Parent (N)) in N_Op + then + Orig_T := Etype (Parent (N)); + end if; + + if Is_Entity_Name (Orig_N) + and then Etype (Entity (Orig_N)) = Orig_T + then + Error_Msg_NE + ("?useless conversion, & has this type", N, Entity (Orig_N)); + end if; + end if; + + -- Ada 2005 (AI-251): Handle conversions to abstract interface types + + if Ada_Version >= Ada_05 then + if Is_Access_Type (Target_Type) then + Target_Type := Directly_Designated_Type (Target_Type); + end if; + + if Is_Class_Wide_Type (Target_Type) then + Target_Type := Etype (Target_Type); + end if; + + if Is_Interface (Target_Type) then + if Is_Access_Type (Opnd_Type) then + Opnd_Type := Directly_Designated_Type (Opnd_Type); + end if; + + if Is_Class_Wide_Type (Opnd_Type) then + Opnd_Type := Etype (Opnd_Type); + end if; + + if not Interface_Present_In_Ancestor + (Typ => Opnd_Type, + Iface => Target_Type) + then + Error_Msg_NE + ("(Ada 2005) does not implement interface }", + Operand, Target_Type); + + else + -- If a conversion to an interface type appears as an actual in + -- a source call, it will be expanded when the enclosing call + -- itself is examined in Expand_Interface_Formals. Otherwise, + -- generate the proper conversion code now, using the tag of + -- the interface. + + if (Nkind (Parent (N)) = N_Procedure_Call_Statement + or else Nkind (Parent (N)) = N_Function_Call) + and then Comes_From_Source (N) + then + null; + else + Expand_Interface_Conversion (N); + end if; + end if; + end if; end if; end Resolve_Type_Conversion; @@ -5637,30 +6683,57 @@ package body Sem_Res is ---------------------- procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id) is - B_Typ : Entity_Id := Base_Type (Typ); - R : constant Node_Id := Right_Opnd (N); + B_Typ : constant Entity_Id := Base_Type (Typ); + R : constant Node_Id := Right_Opnd (N); + OK : Boolean; + Lo : Uint; + Hi : Uint; begin + -- Generate warning for expressions like abs (x mod 2) + + if Warn_On_Redundant_Constructs + and then Nkind (N) = N_Op_Abs + then + Determine_Range (Right_Opnd (N), OK, Lo, Hi); + + if OK and then Hi >= Lo and then Lo >= 0 then + Error_Msg_N + ("?abs applied to known non-negative value has no effect", N); + end if; + end if; + -- Generate warning for expressions like -5 mod 3 if Paren_Count (N) = 0 and then Nkind (N) = N_Op_Minus and then Nkind (Right_Opnd (N)) = N_Op_Mod + and then Comes_From_Source (N) then Error_Msg_N ("?unary minus expression should be parenthesized here", N); 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; + if Etype (R) = Universal_Integer - or else Etype (R) = Universal_Real + or else Etype (R) = Universal_Real then Check_For_Visible_Operator (N, B_Typ); end if; Set_Etype (N, B_Typ); Resolve (R, B_Typ); + Check_Unset_Reference (R); - Generate_Operator_Reference (N); + Generate_Operator_Reference (N, B_Typ); Eval_Unary_Op (N); -- Set overflow checking bit. Much cleverer code needed here eventually @@ -5669,10 +6742,9 @@ package body Sem_Res is if Nkind (N) in N_Op then if not Overflow_Checks_Suppressed (Etype (N)) then - Set_Do_Overflow_Check (N, True); + Enable_Overflow_Check (N); end if; end if; - end Resolve_Unary_Op; ---------------------------------- @@ -5696,11 +6768,13 @@ package body Sem_Res is (N : Node_Id; Typ : Entity_Id) is + pragma Warnings (Off, Typ); + Operand : constant Node_Id := Expression (N); Opnd_Type : constant Entity_Id := Etype (Operand); begin - -- Resolve operand using its own type. + -- Resolve operand using its own type Resolve (Operand, Opnd_Type); Eval_Unchecked_Conversion (N); @@ -5712,8 +6786,8 @@ package body Sem_Res is ------------------------------ procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id) is - Loc : Source_Ptr := Sloc (N); - Actuals : List_Id := New_List; + Loc : constant Source_Ptr := Sloc (N); + Actuals : constant List_Id := New_List; New_N : Node_Id; begin @@ -5738,23 +6812,33 @@ package body Sem_Res is -- Rewrite_Renamed_Operator -- ------------------------------ - procedure Rewrite_Renamed_Operator (N : Node_Id; Op : Entity_Id) is + procedure Rewrite_Renamed_Operator + (N : Node_Id; + Op : Entity_Id; + Typ : Entity_Id) + is Nam : constant Name_Id := Chars (Op); Is_Binary : constant Boolean := Nkind (N) in N_Binary_Op; Op_Node : Node_Id; begin - if Chars (N) /= Nam then - - -- Rewrite the operator node using the real operator, not its - -- renaming. + -- Rewrite the operator node using the real operator, not its + -- renaming. Exclude user-defined intrinsic operations of the same + -- name, which are treated separately and rewritten as calls. + if Ekind (Op) /= E_Function + or else Chars (N) /= Nam + then Op_Node := New_Node (Operator_Kind (Nam, Is_Binary), Sloc (N)); Set_Chars (Op_Node, Nam); Set_Etype (Op_Node, Etype (N)); Set_Entity (Op_Node, Op); Set_Right_Opnd (Op_Node, Right_Opnd (N)); + -- Indicate that both the original entity and its renaming + -- are referenced at this point. + + Generate_Reference (Entity (N), N); Generate_Reference (Op, N); if Is_Binary then @@ -5762,6 +6846,36 @@ package body Sem_Res is end if; Rewrite (N, Op_Node); + + -- If the context type is private, add the appropriate conversions + -- so that the operator is applied to the full view. This is done + -- in the routines that resolve intrinsic operators, + + if Is_Intrinsic_Subprogram (Op) + and then Is_Private_Type (Typ) + then + case Nkind (N) is + when N_Op_Add | N_Op_Subtract | N_Op_Multiply | N_Op_Divide | + N_Op_Expon | N_Op_Mod | N_Op_Rem => + Resolve_Intrinsic_Operator (N, Typ); + + when N_Op_Plus | N_Op_Minus | N_Op_Abs => + Resolve_Intrinsic_Unary_Operator (N, Typ); + + when others => + Resolve (N, Typ); + end case; + end if; + + elsif Ekind (Op) = E_Function + and then Is_Intrinsic_Subprogram (Op) + then + -- Operator renames a user-defined operator of the same name. Use + -- the original operator in the node, which is the one that gigi + -- knows about. + + Set_Entity (N, Op); + Set_Is_Overloaded (N, False); end if; end Rewrite_Renamed_Operator; @@ -5778,8 +6892,8 @@ package body Sem_Res is procedure Set_Slice_Subtype (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); + Index_List : constant List_Id := New_List; Index : Node_Id; - Index_List : List_Id := New_List; Index_Subtype : Entity_Id; Index_Type : Entity_Id; Slice_Subtype : Entity_Id; @@ -5817,7 +6931,6 @@ package body Sem_Res is Set_Etype (Index, Index_Subtype); Append (Index, Index_List); - Set_Component_Type (Slice_Subtype, Component_Type (Etype (N))); Set_First_Index (Slice_Subtype, Index); Set_Etype (Slice_Subtype, Base_Type (Etype (N))); Set_Is_Constrained (Slice_Subtype, True); @@ -5852,16 +6965,14 @@ package body Sem_Res is begin if Nkind (N) /= N_String_Literal then return; - else Subtype_Id := Create_Itype (E_String_Literal_Subtype, N); end if; - Set_Component_Type (Subtype_Id, Component_Type (Typ)); - Set_String_Literal_Length (Subtype_Id, - UI_From_Int (String_Length (Strval (N)))); - Set_Etype (Subtype_Id, Base_Type (Typ)); - Set_Is_Constrained (Subtype_Id); + Set_String_Literal_Length (Subtype_Id, UI_From_Int + (String_Length (Strval (N)))); + Set_Etype (Subtype_Id, Base_Type (Typ)); + Set_Is_Constrained (Subtype_Id); -- The low bound is set from the low bound of the corresponding -- index type. Note that we do not store the high bound in the @@ -5885,7 +6996,11 @@ package body Sem_Res is Scop : Entity_Id; procedure Fixed_Point_Error; - -- If true ambiguity, give details. + -- If true ambiguity, give details + + ----------------------- + -- Fixed_Point_Error -- + ----------------------- procedure Fixed_Point_Error is begin @@ -5894,19 +7009,19 @@ package body Sem_Res is Error_Msg_NE ("\possible interpretation as}", N, T2); end Fixed_Point_Error; + -- Start of processing for Unique_Fixed_Point_Type + begin -- The operations on Duration are visible, so Duration is always a -- possible interpretation. T1 := Standard_Duration; - Scop := Current_Scope; - - -- Look for fixed-point types in enclosing scopes. + -- Look for fixed-point types in enclosing scopes + Scop := Current_Scope; while Scop /= Standard_Standard loop T2 := First_Entity (Scop); - while Present (T2) loop if Is_Fixed_Point_Type (T2) and then Current_Entity (T2) = T2 @@ -5926,16 +7041,13 @@ package body Sem_Res is Scop := Scope (Scop); end loop; - -- Look for visible fixed type declarations in the context. + -- Look for visible fixed type declarations in the context Item := First (Context_Items (Cunit (Current_Sem_Unit))); - while Present (Item) loop - if Nkind (Item) = N_With_Clause then Scop := Entity (Name (Item)); T2 := First_Entity (Scop); - while Present (T2) loop if Is_Fixed_Point_Type (T2) and then Scope (Base_Type (T2)) = Scop @@ -5974,22 +7086,19 @@ package body Sem_Res is function Valid_Conversion (N : Node_Id; Target : Entity_Id; - Operand : Node_Id) - return Boolean + Operand : Node_Id) return Boolean is - Target_Type : Entity_Id := Base_Type (Target); + Target_Type : constant Entity_Id := Base_Type (Target); Opnd_Type : Entity_Id := Etype (Operand); function Conversion_Check (Valid : Boolean; - Msg : String) - return Boolean; + Msg : String) return Boolean; -- Little routine to post Msg if Valid is False, returns Valid value function Valid_Tagged_Conversion (Target_Type : Entity_Id; - Opnd_Type : Entity_Id) - return Boolean; + Opnd_Type : Entity_Id) return Boolean; -- Specifically test for validity of tagged conversions ---------------------- @@ -5998,8 +7107,7 @@ package body Sem_Res is function Conversion_Check (Valid : Boolean; - Msg : String) - return Boolean + Msg : String) return Boolean is begin if not Valid then @@ -6015,19 +7123,18 @@ package body Sem_Res is function Valid_Tagged_Conversion (Target_Type : Entity_Id; - Opnd_Type : Entity_Id) - return Boolean + Opnd_Type : Entity_Id) return Boolean is begin - -- Upward conversions are allowed (RM 4.6(22)). + -- Upward conversions are allowed (RM 4.6(22)) if Covers (Target_Type, Opnd_Type) or else Is_Ancestor (Target_Type, Opnd_Type) then return True; - -- Downward conversion are allowed if the operand is - -- is class-wide (RM 4.6(23)). + -- Downward conversion are allowed if the operand is class-wide + -- (RM 4.6(23)). elsif Is_Class_Wide_Type (Opnd_Type) and then Covers (Opnd_Type, Target_Type) @@ -6040,6 +7147,13 @@ package body Sem_Res is return 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 + + elsif Is_Interface (Target_Type) then + return True; + else Error_Msg_NE ("invalid tagged conversion, not compatible with}", @@ -6066,14 +7180,26 @@ package body Sem_Res is -- 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. + Get_First_Interp (Operand, I, It); while Present (It.Typ) loop - if It.Typ = Standard_Void_Type then Remove_Interp (I); end if; + if Present (System_Aux_Id) + and then Is_Descendent_Of_Address (It.Typ) + then + Remove_Interp (I); + end if; + Get_Next_Interp (I, It); end loop; @@ -6120,6 +7246,12 @@ package body Sem_Res is 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; + else return Conversion_Check (Is_Numeric_Type (Opnd_Type), "illegal operand for numeric conversion"); @@ -6143,14 +7275,16 @@ package body Sem_Res is else declare - Target_Index : Node_Id := First_Index (Target_Type); - Opnd_Index : Node_Id := First_Index (Opnd_Type); + Target_Index : Node_Id := First_Index (Target_Type); + Opnd_Index : Node_Id := First_Index (Opnd_Type); Target_Index_Type : Entity_Id; Opnd_Index_Type : Entity_Id; - Target_Comp_Type : Entity_Id := Component_Type (Target_Type); - Opnd_Comp_Type : Entity_Id := Component_Type (Opnd_Type); + 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 @@ -6196,6 +7330,94 @@ package body Sem_Res is return True; + -- Ada 2005 (AI-251) + + elsif (Ekind (Target_Type) = E_General_Access_Type + or else Ekind (Target_Type) = E_Anonymous_Access_Type) + and then Is_Interface (Directly_Designated_Type (Target_Type)) + then + -- Check the static accessibility rule of 4.6(17). Note that the + -- check is not enforced when within an instance body, since the RM + -- requires such cases to be caught at run time. + + if Ekind (Target_Type) /= E_Anonymous_Access_Type then + if Type_Access_Level (Opnd_Type) > + Type_Access_Level (Target_Type) + then + -- In an instance, this is a run-time check, but one we know + -- will fail, so generate an appropriate warning. The raise + -- will be generated by Expand_N_Type_Conversion. + + if In_Instance_Body then + Error_Msg_N + ("?cannot convert local pointer to non-local access type", + Operand); + Error_Msg_N + ("?Program_Error will be raised at run time", Operand); + + else + Error_Msg_N + ("cannot convert local pointer to non-local access type", + Operand); + return False; + end if; + + -- Special accessibility checks are needed in the case of access + -- discriminants declared for a limited type. + + elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type + and then not Is_Local_Anonymous_Access (Opnd_Type) + then + -- When the operand is a selected access discriminant the check + -- needs to be made against the level of the object denoted by + -- the prefix of the selected name. (Object_Access_Level + -- handles checking the prefix of the operand for this case.) + + if Nkind (Operand) = N_Selected_Component + and then Object_Access_Level (Operand) + > Type_Access_Level (Target_Type) + then + -- In an instance, this is a run-time check, but one we + -- know will fail, so generate an appropriate warning. + -- The raise will be generated by Expand_N_Type_Conversion. + + if In_Instance_Body then + Error_Msg_N + ("?cannot convert access discriminant to non-local" & + " access type", Operand); + Error_Msg_N + ("?Program_Error will be raised at run time", Operand); + + else + Error_Msg_N + ("cannot convert access discriminant to non-local" & + " access type", Operand); + return False; + end if; + end if; + + -- The case of a reference to an access discriminant from + -- within a limited type declaration (which will appear as + -- a discriminal) is always illegal because the level of the + -- discriminant is considered to be deeper than any (namable) + -- access type. + + if Is_Entity_Name (Operand) + and then not Is_Local_Anonymous_Access (Opnd_Type) + and then (Ekind (Entity (Operand)) = E_In_Parameter + or else Ekind (Entity (Operand)) = E_Constant) + and then Present (Discriminal_Link (Entity (Operand))) + then + Error_Msg_N + ("discriminant has deeper accessibility level than target", + Operand); + return False; + end if; + end if; + end if; + + return True; + elsif (Ekind (Target_Type) = E_General_Access_Type or else Ekind (Target_Type) = E_Anonymous_Access_Type) and then @@ -6215,11 +7437,13 @@ package body Sem_Res is return False; end if; - -- Check the static accessibility rule of 4.6(17). Note that - -- the check is not enforced when within an instance body, since - -- the RM requires such cases to be caught at run time. + -- Check the static accessibility rule of 4.6(17). Note that the + -- check is not enforced when within an instance body, since the RM + -- requires such cases to be caught at run time. - if Ekind (Target_Type) /= E_Anonymous_Access_Type then + if Ekind (Target_Type) /= E_Anonymous_Access_Type + or else Is_Local_Anonymous_Access (Target_Type) + then if Type_Access_Level (Opnd_Type) > Type_Access_Level (Target_Type) then @@ -6241,13 +7465,17 @@ package body Sem_Res is return False; end if; - elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type then + -- Special accessibility checks are needed in the case of access + -- discriminants declared for a limited type. - -- 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.) + elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type + and then not Is_Local_Anonymous_Access (Opnd_Type) + then + + -- When the operand is a selected access discriminant the check + -- needs to be made against the level of the object denoted by + -- the prefix of the selected name. (Object_Access_Level + -- handles checking the prefix of the operand for this case.) if Nkind (Operand) = N_Selected_Component and then Object_Access_Level (Operand) @@ -6272,11 +7500,11 @@ package body Sem_Res is end if; end if; - -- The case of a reference to an access discriminant - -- from within a type declaration (which will appear - -- as a discriminal) is always illegal because the - -- level of the discriminant is considered to be - -- deeper than any (namable) access type. + -- 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) + -- access type. if Is_Entity_Name (Operand) and then (Ekind (Entity (Operand)) = E_In_Parameter @@ -6306,35 +7534,42 @@ package body Sem_Res is N, Base_Type (Opnd)); return False; - elsif not Subtypes_Statically_Match (Target, Opnd) - and then (not Has_Discriminants (Target) - or else Is_Constrained (Target)) + -- Ada 2005 AI-384: legality rule is symmetric in both + -- designated types. The conversion is legal (with possible + -- constraint check) if either designated type is + -- unconstrained. + + elsif Subtypes_Statically_Match (Target, Opnd) + or else + (Has_Discriminants (Target) + and then + (not Is_Constrained (Opnd) + or else not Is_Constrained (Target))) then + return True; + + else Error_Msg_NE ("target designated subtype not compatible with }", N, Opnd); return False; - - else - return True; end if; end if; end; - elsif Ekind (Target_Type) = E_Access_Subprogram_Type + elsif (Ekind (Target_Type) = E_Access_Subprogram_Type + or else + Ekind (Target_Type) = E_Anonymous_Access_Subprogram_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 -- Check that the designated types are subtype conformant - if not Subtype_Conformant (Designated_Type (Opnd_Type), - Designated_Type (Target_Type)) - then - Error_Msg_N - ("operand type is not subtype conformant with target type", - Operand); - end if; + Check_Subtype_Conformant (New_Id => Designated_Type (Target_Type), + Old_Id => Designated_Type (Opnd_Type), + Err_Loc => N); -- Check the static accessibility rule of 4.6(20) @@ -6354,10 +7589,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; @@ -6390,7 +7625,7 @@ package body Sem_Res is elsif Is_Tagged_Type (Target_Type) then return Valid_Tagged_Conversion (Target_Type, Opnd_Type); - -- Types derived from the same root type are convertible. + -- Types derived from the same root type are convertible elsif Root_Type (Target_Type) = Root_Type (Opnd_Type) then return True;