From: Hristian Kirtchev Date: Wed, 6 Jun 2007 10:43:57 +0000 (+0200) Subject: sem_res.ads, [...] (Process_Allocator): Do not propagate the chain of coextensions... X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=b7d1f17ff2605ae0dda0f3568136ff76cfcb879e;p=gcc.git sem_res.ads, [...] (Process_Allocator): Do not propagate the chain of coextensions when... 2007-04-20 Hristian Kirtchev Ed Schonberg Robert Dewar Javier Miranda * sem_res.ads, sem_res.adb (Process_Allocator): Do not propagate the chain of coextensions when an allocator serves as the root of such a chain. (Propagate_Coextensions): Remove the test for the root being an allocator. (Resolve_Allocator): Add condition to ensure that all future decoration occurs on an allocator node. Add processing and cleanup for static coextensions. (Valid_Conversion): If the operand type is the limited view of a class-wide type, use the non-limited view is available to determine legality of operation. (Ambiguous_Character): move to spec, for use elsewhere. (Ambiguous_Character): Handle Wide_Wide_Character in Ada 2005 mode (Resolve_Range): Diagnose properly an ambiguous range whose bounds are character literals. (Resolve_Arithmetic_Op): Call Activate_Division_Check instead of setting Do_Division_Check flag explicitly. (Resolve_Actuals): If the actual is of a synchronized type, and the formal is of the corresponding record type, this is a call to a primitive operation of the type, that is declared outside of the type; the actual must be unchecked-converted to the type of the actual (Resolve_Call): Kill all current values for any subprogram call if flag Suppress_Value_Tracking_On_Call is set. (Resolve_Type_Conversion): Generate error message the the operand or target of interface conversions come from a limited view. (Check_Infinite_Recursion): Ignore generated calls (Check_Allocator_Discrim_Accessibility): New procedure for checking that an expression that constrains an access discriminant in an allocator does not denote an object with a deeper level than the allocator's access type. (Resolve_Allocator): In the case of an allocator initialized by an aggregate of a discriminated type, check that associations for any access discriminants satisfy accessibility requirements by calling Check_Allocator_Discrim_Accessibility. (Resolve_Equality_Op): Handle comparisons of anonymous access to subprogram types in the same fashion as other anonymous access types. (Resolve_Concatenation_Arg): Remove initial character '\' in an error message that is not a continuation message. (Resolve_Type_Conversion): Add missing support for conversion to interface type. (Resolve_Actuals): Introduce a transient scope around the call if an actual is a call to a function returning a limited type, because the resulting value must be finalized after the call. (Resolve_Actuals): If the call was given in prefix notations, check whether an implicit 'Access reference or implicit dereference must be added to make the actual conform to the controlling formal. From-SVN: r125451 --- diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 8a0f531b920..a2b8b23ca5d 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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- -- @@ -29,6 +29,7 @@ with Checks; use Checks; with Debug; use Debug; with Debug_A; use Debug_A; with Einfo; use Einfo; +with Elists; use Elists; with Errout; use Errout; with Expander; use Expander; with Exp_Disp; use Exp_Disp; @@ -67,6 +68,7 @@ with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; +with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; with Urealp; use Urealp; @@ -86,10 +88,6 @@ package body Sem_Res is -- Note that Resolve_Attribute is separated off in Sem_Attr - procedure Ambiguous_Character (C : Node_Id); - -- Give list of candidate interpretations when a character literal cannot - -- be resolved. - procedure Check_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). @@ -245,8 +243,22 @@ package body Sem_Res is begin if Nkind (C) = N_Character_Literal then Error_Msg_N ("ambiguous character literal", C); + + -- First the ones in Standard + Error_Msg_N - ("\\possible interpretations: Character, Wide_Character!", C); + ("\\possible interpretation: Character!", C); + Error_Msg_N + ("\\possible interpretation: Wide_Character!", C); + + -- Include Wide_Wide_Character in Ada 2005 mode + + if Ada_Version >= Ada_05 then + Error_Msg_N + ("\\possible interpretation: Wide_Wide_Character!", C); + end if; + + -- Now any other types that match E := Current_Entity (C); while Present (E) loop @@ -1679,6 +1691,7 @@ package body Sem_Res is Old_Id => Designated_Type (Corresponding_Remote_Type (Typ)), Err_Loc => N); + if Is_Remote then Process_Remote_AST_Attribute (N, Typ); end if; @@ -2462,6 +2475,13 @@ package body Sem_Res is F_Typ : Entity_Id; Prev : Node_Id := Empty; + procedure Check_Prefixed_Call; + -- If the original node is an overloaded call in prefix notation, + -- insert an 'Access or a dereference as needed over the first actual. + -- Try_Object_Operation has already verified that there is a valid + -- interpretation, but the form of the actual can only be determined + -- once the primitive operation is identified. + procedure Insert_Default; -- If the actual is missing in a call, insert in the actuals list -- an instance of the default expression. The insertion is always @@ -2472,6 +2492,62 @@ package body Sem_Res is -- common type. Used to enforce the restrictions on array conversions -- of AI95-00246. + ------------------------- + -- Check_Prefixed_Call -- + ------------------------- + + procedure Check_Prefixed_Call is + Act : constant Node_Id := First_Actual (N); + A_Type : constant Entity_Id := Etype (Act); + F_Type : constant Entity_Id := Etype (First_Formal (Nam)); + Orig : constant Node_Id := Original_Node (N); + New_A : Node_Id; + + begin + -- Check whether the call is a prefixed call, with or without + -- additional actuals. + + if Nkind (Orig) = N_Selected_Component + or else + (Nkind (Orig) = N_Indexed_Component + and then Nkind (Prefix (Orig)) = N_Selected_Component + and then Is_Entity_Name (Prefix (Prefix (Orig))) + and then Is_Entity_Name (Act) + and then Chars (Act) = Chars (Prefix (Prefix (Orig)))) + then + if Is_Access_Type (A_Type) + and then not Is_Access_Type (F_Type) + then + -- Introduce dereference on object in prefix + + New_A := + Make_Explicit_Dereference (Sloc (Act), + Prefix => Relocate_Node (Act)); + Rewrite (Act, New_A); + Analyze (Act); + + elsif Is_Access_Type (F_Type) + and then not Is_Access_Type (A_Type) + then + -- Introduce an implicit 'Access in prefix + + if not Is_Aliased_View (Act) then + Error_Msg_NE + ("object in prefixed call to& must be aliased" + & " ('R'M'-2005 4.3.1 (13))", + Prefix (Act), Nam); + end if; + + Rewrite (Act, + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Access, + Prefix => Relocate_Node (Act))); + end if; + + Analyze (Act); + end if; + end Check_Prefixed_Call; + -------------------- -- Insert_Default -- -------------------- @@ -2493,8 +2569,11 @@ package body Sem_Res is -- 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); + Actval := + New_Copy_Tree + (Default_Value (F), + New_Scope => Current_Scope, + New_Sloc => Loc); if Is_Concurrent_Type (Scope (Nam)) and then Has_Discriminants (Scope (Nam)) @@ -2649,6 +2728,10 @@ package body Sem_Res is -- Start of processing for Resolve_Actuals begin + if Present (First_Actual (N)) then + Check_Prefixed_Call; + end if; + A := First_Actual (N); F := First_Formal (Nam); while Present (F) loop @@ -2730,6 +2813,20 @@ package body Sem_Res is Resolve (Expression (A)); end if; + -- If the actual is a function call that returns a limited + -- unconstrained object that needs finalization, create a + -- transient scope for it, so that it can receive the proper + -- finalization list. + + elsif Nkind (A) = N_Function_Call + and then Is_Limited_Record (Etype (F)) + and then not Is_Constrained (Etype (F)) + and then Expander_Active + and then + (Is_Controlled (Etype (F)) or else Has_Task (Etype (F))) + then + Establish_Transient_Scope (A, False); + else if Nkind (A) = N_Type_Conversion and then Is_Array_Type (Etype (F)) @@ -2778,16 +2875,32 @@ package body Sem_Res is -- Ada 2005, AI-162:If the actual is an allocator, the -- innermost enclosing statement is the master of the - -- created object. + -- created object. This needs to be done with expansion + -- enabled only, otherwise the transient scope will not + -- be removed in the expansion of the wrapped construct. - if Is_Controlled (DDT) - or else Has_Task (DDT) + if (Is_Controlled (DDT) + or else Has_Task (DDT)) + and then Expander_Active then Establish_Transient_Scope (A, False); end if; end; end if; + -- (Ada 2005): The call may be to a primitive operation of + -- a tagged synchronized type, declared outside of the type. + -- In this case the controlling actual must be converted to + -- its corresponding record type, which is the formal type. + + if Is_Concurrent_Type (Etype (A)) + and then Etype (F) = Corresponding_Record_Type (Etype (A)) + then + Rewrite (A, + Unchecked_Convert_To + (Corresponding_Record_Type (Etype (A)), A)); + end if; + Resolve (A, Etype (F)); end if; @@ -3072,12 +3185,104 @@ package body Sem_Res is Subtyp : Entity_Id; Discrim : Entity_Id; Constr : Node_Id; + Aggr : Node_Id; + Assoc : Node_Id := Empty; Disc_Exp : Node_Id; + procedure Check_Allocator_Discrim_Accessibility + (Disc_Exp : Node_Id; + Alloc_Typ : Entity_Id); + -- Check that accessibility level associated with an access discriminant + -- initialized in an allocator by the expression Disc_Exp is not deeper + -- than the level of the allocator type Alloc_Typ. An error message is + -- issued if this condition is violated. Specialized checks are done for + -- the cases of a constraint expression which is an access attribute or + -- an access discriminant. + function In_Dispatching_Context return Boolean; - -- If the allocator is an actual in a call, it is allowed to be - -- class-wide when the context is not because it is a controlling - -- actual. + -- If the allocator is an actual in a call, it is allowed to be class- + -- wide when the context is not because it is a controlling actual. + + procedure Propagate_Coextensions (Root : Node_Id); + -- Propagate all nested coextensions which are located one nesting + -- level down the tree to the node Root. Example: + -- + -- Top_Record + -- Level_1_Coextension + -- Level_2_Coextension + -- + -- The algorithm is paired with delay actions done by the Expander. In + -- the above example, assume all coextensions are controlled types. + -- The cycle of analysis, resolution and expansion will yield: + -- + -- 1) Analyze Top_Record + -- 2) Analyze Level_1_Coextension + -- 3) Analyze Level_2_Coextension + -- 4) Resolve Level_2_Coextnesion. The allocator is marked as a + -- coextension. + -- 5) Expand Level_2_Coextension. A temporary variable Temp_1 is + -- generated to capture the allocated object. Temp_1 is attached + -- to the coextension chain of Level_2_Coextension. + -- 6) Resolve Level_1_Coextension. The allocator is marked as a + -- coextension. A forward tree traversal is performed which finds + -- Level_2_Coextension's list and copies its contents into its + -- own list. + -- 7) Expand Level_1_Coextension. A temporary variable Temp_2 is + -- generated to capture the allocated object. Temp_2 is attached + -- to the coextension chain of Level_1_Coextension. Currently, the + -- contents of the list are [Temp_2, Temp_1]. + -- 8) Resolve Top_Record. A forward tree traversal is performed which + -- finds Level_1_Coextension's list and copies its contents into + -- its own list. + -- 9) Expand Top_Record. Generate finalization calls for Temp_1 and + -- Temp_2 and attach them to Top_Record's finalization list. + + ------------------------------------------- + -- Check_Allocator_Discrim_Accessibility -- + ------------------------------------------- + + procedure Check_Allocator_Discrim_Accessibility + (Disc_Exp : Node_Id; + Alloc_Typ : Entity_Id) + is + begin + if Type_Access_Level (Etype (Disc_Exp)) > + Type_Access_Level (Alloc_Typ) + then + Error_Msg_N + ("operand type has deeper level than allocator type", Disc_Exp); + + -- When the expression is an Access attribute the level of the prefix + -- object must not be deeper than that of the allocator's type. + + elsif Nkind (Disc_Exp) = N_Attribute_Reference + and then Get_Attribute_Id (Attribute_Name (Disc_Exp)) + = Attribute_Access + and then Object_Access_Level (Prefix (Disc_Exp)) + > Type_Access_Level (Alloc_Typ) + then + Error_Msg_N + ("prefix of attribute has deeper level than allocator type", + Disc_Exp); + + -- When the expression is an access discriminant the check is against + -- the level of the prefix object. + + elsif Ekind (Etype (Disc_Exp)) = E_Anonymous_Access_Type + and then Nkind (Disc_Exp) = N_Selected_Component + and then Object_Access_Level (Prefix (Disc_Exp)) + > Type_Access_Level (Alloc_Typ) + then + Error_Msg_N + ("access discriminant has deeper level than allocator type", + Disc_Exp); + + -- All other cases are legal + + else + null; + end if; + end Check_Allocator_Discrim_Accessibility; ---------------------------- -- In_Dispatching_Context -- @@ -3085,7 +3290,6 @@ package body Sem_Res is function In_Dispatching_Context return Boolean is Par : constant Node_Id := Parent (N); - begin return (Nkind (Par) = N_Function_Call or else Nkind (Par) = N_Procedure_Call_Statement) @@ -3093,6 +3297,135 @@ package body Sem_Res is and then Is_Dispatching_Operation (Entity (Name (Par))); end In_Dispatching_Context; + ---------------------------- + -- Propagate_Coextensions -- + ---------------------------- + + procedure Propagate_Coextensions (Root : Node_Id) is + + procedure Copy_List (From : Elist_Id; To : Elist_Id); + -- Copy the contents of list From into list To, preserving the + -- order of elements. + + function Process_Allocator (Nod : Node_Id) return Traverse_Result; + -- Recognize an allocator or a rewritten allocator node and add it + -- allong with its nested coextensions to the list of Root. + + --------------- + -- Copy_List -- + --------------- + + procedure Copy_List (From : Elist_Id; To : Elist_Id) is + From_Elmt : Elmt_Id; + begin + From_Elmt := First_Elmt (From); + while Present (From_Elmt) loop + Append_Elmt (Node (From_Elmt), To); + Next_Elmt (From_Elmt); + end loop; + end Copy_List; + + ----------------------- + -- Process_Allocator -- + ----------------------- + + function Process_Allocator (Nod : Node_Id) return Traverse_Result is + Orig_Nod : Node_Id := Nod; + + begin + -- This is a possible rewritten subtype indication allocator. Any + -- nested coextensions will appear as discriminant constraints. + + if Nkind (Nod) = N_Identifier + and then Present (Original_Node (Nod)) + and then Nkind (Original_Node (Nod)) = N_Subtype_Indication + then + declare + Discr : Node_Id; + Discr_Elmt : Elmt_Id; + + begin + if Is_Record_Type (Entity (Nod)) then + Discr_Elmt := + First_Elmt (Discriminant_Constraint (Entity (Nod))); + while Present (Discr_Elmt) loop + Discr := Node (Discr_Elmt); + + if Nkind (Discr) = N_Identifier + and then Present (Original_Node (Discr)) + and then Nkind (Original_Node (Discr)) = N_Allocator + and then Present (Coextensions ( + Original_Node (Discr))) + then + if No (Coextensions (Root)) then + Set_Coextensions (Root, New_Elmt_List); + end if; + + Copy_List + (From => Coextensions (Original_Node (Discr)), + To => Coextensions (Root)); + end if; + + Next_Elmt (Discr_Elmt); + end loop; + + -- There is no need to continue the traversal of this + -- subtree since all the information has already been + -- propagated. + + return Skip; + end if; + end; + + -- Case of either a stand alone allocator or a rewritten allocator + -- with an aggregate. + + else + if Present (Original_Node (Nod)) then + Orig_Nod := Original_Node (Nod); + end if; + + if Nkind (Orig_Nod) = N_Allocator then + + -- Propagate the list of nested coextensions to the Root + -- allocator. This is done through list copy since a single + -- allocator may have multiple coextensions. Do not touch + -- coextensions roots. + + if not Is_Coextension_Root (Orig_Nod) + and then Present (Coextensions (Orig_Nod)) + then + if No (Coextensions (Root)) then + Set_Coextensions (Root, New_Elmt_List); + end if; + + Copy_List + (From => Coextensions (Orig_Nod), + To => Coextensions (Root)); + end if; + + -- There is no need to continue the traversal of this + -- subtree since all the information has already been + -- propagated. + + return Skip; + end if; + end if; + + -- Keep on traversing, looking for the next allocator + + return OK; + end Process_Allocator; + + procedure Process_Allocators is + new Traverse_Proc (Process_Allocator); + + -- Start of processing for Propagate_Coextensions + + begin + Process_Allocators (Expression (Root)); + end Propagate_Coextensions; + -- Start of processing for Resolve_Allocator begin @@ -3131,6 +3464,78 @@ package body Sem_Res is Wrong_Type (Expression (E), Etype (E)); end if; + -- A special accessibility check is needed for allocators that + -- constrain access discriminants. The level of the type of the + -- expression used to constrain an access discriminant cannot be + -- deeper than the type of the allocator (in constrast to access + -- parameters, where the level of the actual can be arbitrary). + + -- We can't use Valid_Conversion to perform this check because + -- in general the type of the allocator is unrelated to the type + -- of the access discriminant. + + if Ekind (Typ) /= E_Anonymous_Access_Type + or else Is_Local_Anonymous_Access (Typ) + then + Subtyp := Entity (Subtype_Mark (E)); + + Aggr := Original_Node (Expression (E)); + + if Has_Discriminants (Subtyp) + and then + (Nkind (Aggr) = N_Aggregate + or else + Nkind (Aggr) = N_Extension_Aggregate) + then + Discrim := First_Discriminant (Base_Type (Subtyp)); + + -- Get the first component expression of the aggregate + + if Present (Expressions (Aggr)) then + Disc_Exp := First (Expressions (Aggr)); + + elsif Present (Component_Associations (Aggr)) then + Assoc := First (Component_Associations (Aggr)); + + if Present (Assoc) then + Disc_Exp := Expression (Assoc); + else + Disc_Exp := Empty; + end if; + + else + Disc_Exp := Empty; + end if; + + while Present (Discrim) and then Present (Disc_Exp) loop + if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then + Check_Allocator_Discrim_Accessibility (Disc_Exp, Typ); + end if; + + Next_Discriminant (Discrim); + + if Present (Discrim) then + if Present (Assoc) then + Next (Assoc); + Disc_Exp := Expression (Assoc); + + elsif Present (Next (Disc_Exp)) then + Next (Disc_Exp); + + else + Assoc := First (Component_Associations (Aggr)); + + if Present (Assoc) then + Disc_Exp := Expression (Assoc); + else + Disc_Exp := Empty; + end if; + end if; + end if; + end loop; + end if; + end if; + -- For a subtype mark or subtype indication, freeze the subtype else @@ -3143,17 +3548,16 @@ package body Sem_Res is -- A special accessibility check is needed for allocators that -- constrain access discriminants. The level of the type of the - -- expression used to contrain an access discriminant cannot be + -- expression used to constrain an access discriminant cannot be -- deeper than the type of the allocator (in constrast to access -- parameters, where the level of the actual can be arbitrary). -- We can't use Valid_Conversion to perform this check because -- in general the type of the allocator is unrelated to the type - -- of the access discriminant. Note that specialized checks are - -- needed for the cases of a constraint expression which is an - -- access attribute or an access discriminant. + -- of the access discriminant. if Nkind (Original_Node (E)) = N_Subtype_Indication - and then Ekind (Typ) /= E_Anonymous_Access_Type + and then (Ekind (Typ) /= E_Anonymous_Access_Type + or else Is_Local_Anonymous_Access (Typ)) then Subtyp := Entity (Subtype_Mark (Original_Node (E))); @@ -3168,36 +3572,9 @@ package body Sem_Res is Disc_Exp := Original_Node (Constr); end if; - if Type_Access_Level (Etype (Disc_Exp)) - > Type_Access_Level (Typ) - then - Error_Msg_N - ("operand type has deeper level than allocator type", - Disc_Exp); - - elsif Nkind (Disc_Exp) = N_Attribute_Reference - and then Get_Attribute_Id (Attribute_Name (Disc_Exp)) - = Attribute_Access - and then Object_Access_Level (Prefix (Disc_Exp)) - > Type_Access_Level (Typ) - then - Error_Msg_N - ("prefix of attribute has deeper level than" - & " allocator type", Disc_Exp); - - -- When the operand is an access discriminant the check - -- is against the level of the prefix object. - - elsif Ekind (Etype (Disc_Exp)) = E_Anonymous_Access_Type - and then Nkind (Disc_Exp) = N_Selected_Component - and then Object_Access_Level (Prefix (Disc_Exp)) - > Type_Access_Level (Typ) - then - Error_Msg_N - ("access discriminant has deeper level than" - & " allocator type", Disc_Exp); - end if; + Check_Allocator_Discrim_Accessibility (Disc_Exp, Typ); end if; + Next_Discriminant (Discrim); Next (Constr); end loop; @@ -3217,7 +3594,7 @@ package body Sem_Res is and then Is_Class_Wide_Type (Designated_Type (Typ)) then declare - Exp_Typ : Entity_Id; + Exp_Typ : Entity_Id; begin if Nkind (E) = N_Qualified_Expression then @@ -3275,6 +3652,34 @@ package body Sem_Res is Set_Associated_Storage_Pool (Typ, Associated_Storage_Pool (Etype (Parent (N)))); end if; + + -- An erroneous allocator may be rewritten as a raise Program_Error + -- statement. + + if Nkind (N) = N_Allocator then + + -- An anonymous access discriminant is the definition of a + -- coextension + + if Ekind (Typ) = E_Anonymous_Access_Type + and then Nkind (Associated_Node_For_Itype (Typ)) = + N_Discriminant_Specification + then + -- Avoid marking an allocator as a dynamic coextension if it is + -- withing a static construct. + + if not Is_Static_Coextension (N) then + Set_Is_Coextension (N); + end if; + + -- Cleanup for potential static coextensions + + else + Set_Is_Static_Coextension (N, False); + end if; + + Propagate_Coextensions (N); + end if; end Resolve_Allocator; --------------------------- @@ -3728,7 +4133,7 @@ package body Sem_Res is -- Otherwise just set the flag to check at run time else - Set_Do_Division_Check (N); + Activate_Division_Check (N); end if; end if; end if; @@ -3801,10 +4206,10 @@ package body Sem_Res is Kill_Current_Values; - -- If this is a procedure call which is really an entry call, do the - -- conversion of the procedure call to an entry call. Protected - -- operations use the same circuitry because the name in the call can be - -- an arbitrary expression with special resolution rules. + -- If this is a procedure call which is really an entry call, do + -- the conversion of the procedure call to an entry call. Protected + -- operations use the same circuitry because the name in the call + -- can be an arbitrary expression with special resolution rules. elsif Nkind (Subp) = N_Selected_Component or else Nkind (Subp) = N_Indexed_Component @@ -3878,12 +4283,6 @@ package body Sem_Res is end; end if; - -- Cannot call thread body directly - - if Is_Thread_Body (Nam) then - Error_Msg_N ("cannot call thread body directly", N); - 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 @@ -4049,100 +4448,104 @@ package body Sem_Res is -- If we are calling the current subprogram from immediately within its -- body, then that is the case where we can sometimes detect cases of -- infinite recursion statically. Do not try this in case restriction - -- No_Recursion is in effect anyway. + -- No_Recursion is in effect anyway, and do it only for source calls. - Scop := Current_Scope; + if Comes_From_Source (N) then + Scop := Current_Scope; - if Nam = Scop - and then not Restriction_Active (No_Recursion) - and then Check_Infinite_Recursion (N) - then - -- Here we detected and flagged an infinite recursion, so we do - -- not need to test the case below for further warnings. + if Nam = Scop + and then not Restriction_Active (No_Recursion) + and then Check_Infinite_Recursion (N) + then + -- Here we detected and flagged an infinite recursion, so we do + -- not need to test the case below for further warnings. - null; + null; - -- If call is to immediately containing subprogram, then check for - -- the case of a possible run-time detectable infinite recursion. + -- If call is to immediately containing subprogram, then check for + -- the case of a possible run-time detectable infinite recursion. - else - Scope_Loop : while Scop /= Standard_Standard loop - if Nam = Scop then - - -- Although in general recursion is not statically checkable, - -- the case of calling an immediately containing subprogram - -- is easy to catch. - - Check_Restriction (No_Recursion, N); - - -- If the recursive call is to a parameterless subprogram, then - -- even if we can't statically detect infinite recursion, this - -- is pretty suspicious, and we output a warning. Furthermore, - -- we will try later to detect some cases here at run time by - -- expanding checking code (see Detect_Infinite_Recursion in - -- package Exp_Ch6). - - -- If the recursive call is within a handler we do not emit a - -- warning, because this is a common idiom: loop until input - -- is correct, catch illegal input in handler and restart. - - if No (First_Formal (Nam)) - and then Etype (Nam) = Standard_Void_Type - and then not Error_Posted (N) - and then Nkind (Parent (N)) /= N_Exception_Handler - then - -- For the case of a procedure call. We give the message - -- only if the call is the first statement in a sequence of - -- statements, or if all previous statements are simple - -- assignments. This is simply a heuristic to decrease false - -- positives, without losing too many good warnings. The - -- idea is that these previous statements may affect global - -- variables the procedure depends on. - - if Nkind (N) = N_Procedure_Call_Statement - and then Is_List_Member (N) + else + Scope_Loop : while Scop /= Standard_Standard loop + if Nam = Scop then + + -- Although in general case, recursion is not statically + -- checkable, the case of calling an immediately containing + -- subprogram is easy to catch. + + Check_Restriction (No_Recursion, N); + + -- If the recursive call is to a parameterless subprogram, + -- then even if we can't statically detect infinite + -- recursion, this is pretty suspicious, and we output a + -- warning. Furthermore, we will try later to detect some + -- cases here at run time by expanding checking code (see + -- Detect_Infinite_Recursion in package Exp_Ch6). + + -- If the recursive call is within a handler, do not emit a + -- warning, because this is a common idiom: loop until input + -- is correct, catch illegal input in handler and restart. + + if No (First_Formal (Nam)) + and then Etype (Nam) = Standard_Void_Type + and then not Error_Posted (N) + and then Nkind (Parent (N)) /= N_Exception_Handler then + -- For the case of a procedure call. We give the message + -- only if the call is the first statement in a sequence + -- of statements, or if all previous statements are + -- simple assignments. This is simply a heuristic to + -- decrease false positives, without losing too many good + -- warnings. The idea is that these previous statements + -- may affect global variables the procedure depends on. + + if Nkind (N) = N_Procedure_Call_Statement + and then Is_List_Member (N) + then + declare + P : Node_Id; + begin + P := Prev (N); + while Present (P) loop + if Nkind (P) /= N_Assignment_Statement then + exit Scope_Loop; + end if; + + Prev (P); + end loop; + end; + end if; + + -- Do not give warning if we are in a conditional context + declare - P : Node_Id; + K : constant Node_Kind := Nkind (Parent (N)); begin - P := Prev (N); - while Present (P) loop - if Nkind (P) /= N_Assignment_Statement then - exit Scope_Loop; - end if; - - Prev (P); - end loop; + if (K = N_Loop_Statement + and then Present (Iteration_Scheme (Parent (N)))) + or else K = N_If_Statement + or else K = N_Elsif_Part + or else K = N_Case_Statement_Alternative + then + exit Scope_Loop; + end if; end; - end if; - - -- Do not give warning if we are in a conditional context - declare - K : constant Node_Kind := Nkind (Parent (N)); - begin - if (K = N_Loop_Statement - and then Present (Iteration_Scheme (Parent (N)))) - or else K = N_If_Statement - or else K = N_Elsif_Part - or else K = N_Case_Statement_Alternative - then - exit Scope_Loop; - end if; - end; + -- Here warning is to be issued - -- Here warning is to be issued + Set_Has_Recursive_Call (Nam); + Error_Msg_N + ("possible infinite recursion?", N); + Error_Msg_N + ("\Storage_Error may be raised at run time?", N); + end if; - Set_Has_Recursive_Call (Nam); - Error_Msg_N ("possible infinite recursion?", N); - Error_Msg_N ("\Storage_Error may be raised at run time?", N); + exit Scope_Loop; end if; - exit Scope_Loop; - end if; - - Scop := Scope (Scop); - end loop Scope_Loop; + Scop := Scope (Scop); + end loop Scope_Loop; + end if; end if; -- If subprogram name is a predefined operator, it was given in @@ -4243,18 +4646,25 @@ package body Sem_Res is return; 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 the subprogram is not global, then kill all saved values and + -- checks. This is a bit conservative, since in many cases we could do + -- better, but it is not worth the effort. Similarly, we kill constant + -- values. However we do not need to do this for internal entities + -- (unless they are inherited user-defined subprograms), since they + -- are not in the business of molesting local values. + + -- If the flag Suppress_Value_Tracking_On_Calls is set, then we also + -- kill all checks and values for calls to global subprograms. This + -- takes care of the case where an access to a local subprogram is + -- taken, and could be passed directly or indirectly and then called + -- from almost any context. -- Note: we do not do this step till after resolving the actuals. That -- way we still take advantage of the current value information while -- scanning the actuals. - if not Is_Library_Level_Entity (Nam) + if (not Is_Library_Level_Entity (Nam) + or else Suppress_Value_Tracking_On_Call (Current_Scope)) and then (Comes_From_Source (Nam) or else (Present (Alias (Nam)) and then Comes_From_Source (Alias (Nam)))) @@ -5185,13 +5595,19 @@ package body Sem_Res is -- Ada 2005: If one operand is an anonymous access type, convert -- the other operand to it, to ensure that the underlying types - -- match in the back-end. + -- match in the back-end. Same for access_to_subprogram, and the + -- conversion verifies that the types are subtype conformant. + -- We apply the same conversion in the case one of the operands is -- a private subtype of the type of the other. + -- Why the Expander_Active test here ??? + if Expander_Active - and then (Ekind (T) = E_Anonymous_Access_Type - or else Is_Private_Type (T)) + and then + (Ekind (T) = E_Anonymous_Access_Type + or else Ekind (T) = E_Anonymous_Access_Subprogram_Type + or else Is_Private_Type (T)) then if Etype (L) /= T then Rewrite (L, @@ -5377,8 +5793,14 @@ package body Sem_Res is end if; -- If name was overloaded, set component type correctly now + -- If a misplaced call to an entry family (which has no index typs) + -- return. Error will be diagnosed from calling context. - Set_Etype (N, Component_Type (Array_Type)); + if Is_Array_Type (Array_Type) then + Set_Etype (N, Component_Type (Array_Type)); + else + return; + end if; Index := First_Index (Array_Type); Expr := First (Expressions (N)); @@ -5793,7 +6215,7 @@ package body Sem_Res is if It.Nam = Func then Error_Msg_Sloc := Sloc (Func); - Error_Msg_N ("\ambiguous call to function#", Arg); + Error_Msg_N ("ambiguous call to function#", Arg); Error_Msg_NE ("\\interpretation as call yields&", Arg, Typ); Error_Msg_NE @@ -6134,6 +6556,15 @@ package body Sem_Res is Check_Non_Static_Context (L); Check_Non_Static_Context (H); + -- Check for an ambiguous range over character literals. This will + -- happen with a membership test involving only literals. + + if Typ = Any_Character then + Ambiguous_Character (L); + Set_Etype (N, Any_Type); + return; + end if; + -- If bounds are static, constant-fold them, so size computations -- are identical between front-end and back-end. Do not perform this -- transformation while analyzing generic units, as type information @@ -6581,12 +7012,14 @@ package body Sem_Res is -- if Ada.Tags is already loaded to void the addition of an -- undesired dependence on such run-time unit. - and then not - (RTU_Loaded (Ada_Tags) - and then Nkind (Prefix (N)) = N_Selected_Component - and then Present (Entity (Selector_Name (Prefix (N)))) - and then Entity (Selector_Name (Prefix (N))) - = RTE_Record_Component (RE_Prims_Ptr)) + and then + (VM_Target /= No_VM + or else not + (RTU_Loaded (Ada_Tags) + and then Nkind (Prefix (N)) = N_Selected_Component + and then Present (Entity (Selector_Name (Prefix (N)))) + and then Entity (Selector_Name (Prefix (N))) = + RTE_Record_Component (RE_Prims_Ptr))) then Apply_Range_Check (Drange, Etype (Index)); end if; @@ -6877,18 +7310,16 @@ package body Sem_Res is procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id) is Conv_OK : constant Boolean := Conversion_OK (N); - Target_Type : Entity_Id := Etype (N); - Operand : Node_Id; - Opnd_Type : Entity_Id; + Operand : constant Node_Id := Expression (N); + Operand_Typ : constant Entity_Id := Etype (Operand); + Target_Typ : constant Entity_Id := Etype (N); Rop : Node_Id; Orig_N : Node_Id; Orig_T : Node_Id; begin - Operand := Expression (N); - if not Conv_OK - and then not Valid_Conversion (N, Target_Type, Operand) + and then not Valid_Conversion (N, Target_Typ, Operand) then return; end if; @@ -6957,7 +7388,6 @@ package body Sem_Res is end if; end if; - Opnd_Type := Etype (Operand); Resolve (Operand); -- Note: we do the Eval_Type_Conversion call before applying the @@ -6973,13 +7403,13 @@ package body Sem_Res is -- Even when evaluation is not possible, we may be able to simplify -- the conversion or its expression. This needs to be done before -- applying checks, since otherwise the checks may use the original - -- expression and defeat the simplifications. The is specifically + -- expression and defeat the simplifications. This is specifically -- the case for elimination of the floating-point Truncation -- attribute in float-to-int conversions. Simplify_Type_Conversion (N); - -- If after evaluation, we still have a type conversion, then we + -- If after evaluation we still have a type conversion, then we -- may need to apply checks required for a subtype conversion. -- Skip these type conversion checks if universal fixed operands @@ -6987,9 +7417,9 @@ package body Sem_Res is -- these cases (in the appropriate Expand routines in unit Exp_Fixd). if Nkind (N) = N_Type_Conversion - and then not Is_Generic_Type (Root_Type (Target_Type)) - and then Target_Type /= Universal_Fixed - and then Opnd_Type /= Universal_Fixed + and then not Is_Generic_Type (Root_Type (Target_Typ)) + and then Target_Typ /= Universal_Fixed + and then Operand_Typ /= Universal_Fixed then Apply_Type_Conversion_Checks (N); end if; @@ -7006,7 +7436,7 @@ package body Sem_Res is and then not In_Instance then Orig_N := Original_Node (Expression (Orig_N)); - Orig_T := Target_Type; + Orig_T := Target_Typ; -- If the node is part of a larger expression, the Target_Type -- may not be the original type of the node if the context is a @@ -7026,62 +7456,94 @@ package body Sem_Res is end if; end if; - -- Ada 2005 (AI-251): Handle conversions to abstract interface types + -- Ada 2005 (AI-251): Handle class-wide interface type conversions. -- No need to perform any interface conversion if the type of the -- expression coincides with the target type. if Ada_Version >= Ada_05 and then Expander_Active - and then Opnd_Type /= Target_Type + and then Operand_Typ /= Target_Typ 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; + declare + Opnd : Entity_Id := Operand_Typ; + Target : Entity_Id := Target_Typ; - if Is_Interface (Target_Type) then - if Is_Access_Type (Opnd_Type) then - Opnd_Type := Directly_Designated_Type (Opnd_Type); + begin + if Is_Access_Type (Opnd) then + Opnd := Directly_Designated_Type (Opnd); end if; - if Is_Class_Wide_Type (Opnd_Type) then - Opnd_Type := Etype (Opnd_Type); + if Is_Access_Type (Target_Typ) then + Target := Directly_Designated_Type (Target); end if; - -- Handle subtypes + if Opnd = Target then + null; - if Ekind (Opnd_Type) = E_Protected_Subtype - or else Ekind (Opnd_Type) = E_Task_Subtype - then - Opnd_Type := Etype (Opnd_Type); - end if; + -- Conversion from interface type - if not Interface_Present_In_Ancestor - (Typ => Opnd_Type, - Iface => Target_Type) - then - -- The static analysis is not enough to know if the interface - -- is implemented or not. Hence we must pass the work to the - -- expander to generate the required code to evaluate the - -- conversion at run-time. + elsif Is_Interface (Opnd) then - Expand_Interface_Conversion (N, Is_Static => False); + -- Ada 2005 (AI-217): Handle entities from limited views - else - Expand_Interface_Conversion (N); - end if; + if From_With_Type (Opnd) then + Error_Msg_Qual_Level := 99; + Error_Msg_NE ("missing with-clause on package &", N, + Cunit_Entity (Get_Source_Unit (Base_Type (Opnd)))); + Error_Msg_N + ("type conversions require visibility of the full view", + N); - -- Ada 2005 (AI-251): Conversion from a class-wide interface to a - -- tagged type + elsif From_With_Type (Target) then + Error_Msg_Qual_Level := 99; + Error_Msg_NE ("missing with-clause on package &", N, + Cunit_Entity (Get_Source_Unit (Base_Type (Target)))); + Error_Msg_N + ("type conversions require visibility of the full view", + N); - elsif Is_Class_Wide_Type (Opnd_Type) - and then Is_Interface (Opnd_Type) - then - Expand_Interface_Conversion (N, Is_Static => False); - end if; + else + Expand_Interface_Conversion (N, Is_Static => False); + end if; + + -- Conversion to interface type + + elsif Is_Interface (Target) then + + -- Handle subtypes + + if Ekind (Opnd) = E_Protected_Subtype + or else Ekind (Opnd) = E_Task_Subtype + then + Opnd := Etype (Opnd); + end if; + + if not Interface_Present_In_Ancestor + (Typ => Opnd, + Iface => Target) + then + if Is_Class_Wide_Type (Opnd) then + + -- The static analysis is not enough to know if the + -- interface is implemented or not. Hence we must pass + -- the work to the expander to generate code to evaluate + -- the conversion at run-time. + + Expand_Interface_Conversion (N, Is_Static => False); + + else + Error_Msg_Name_1 := Chars (Etype (Target)); + Error_Msg_Name_2 := Chars (Opnd); + Error_Msg_N + ("wrong interface conversion (% is not a progenitor " & + "of %)", N); + end if; + + else + Expand_Interface_Conversion (N); + end if; + end if; + end; end if; end Resolve_Type_Conversion; @@ -7097,7 +7559,7 @@ package body Sem_Res is Hi : Uint; begin - -- Deal with intrincis unary operators + -- Deal with intrinsic unary operators if Comes_From_Source (N) and then Ekind (Entity (N)) = E_Function @@ -7367,8 +7829,8 @@ package body Sem_Res is Set_Entity (Op_Node, Op); Set_Right_Opnd (Op_Node, Right_Opnd (N)); - -- Indicate that both the original entity and its renaming - -- are referenced at this point. + -- Indicate that both the original entity and its renaming are + -- referenced at this point. Generate_Reference (Entity (N), N); Generate_Reference (Op, N); @@ -7403,7 +7865,7 @@ package body Sem_Res is and then Is_Intrinsic_Subprogram (Op) then -- Operator renames a user-defined operator of the same name. Use - -- the original operator in the node, which is the one that gigi + -- the original operator in the node, which is the one that Gigi -- knows about. Set_Entity (N, Op); @@ -7417,7 +7879,7 @@ package body Sem_Res is -- Build an implicit subtype declaration to represent the type delivered -- by the slice. This is an abbreviated version of an array subtype. We - -- define an index subtype for the slice, using either the subtype name + -- define an index subtype for the slice, using either the subtype name -- or the discrete range of the slice. To be consistent with index usage -- elsewhere, we create a list header to hold the single index. This list -- is not otherwise attached to the syntax tree. @@ -7470,8 +7932,8 @@ package body Sem_Res is Check_Compile_Time_Size (Slice_Subtype); - -- The Etype of the existing Slice node is reset to this slice - -- subtype. Its bounds are obtained from its first index. + -- The Etype of the existing Slice node is reset to this slice subtype. + -- Its bounds are obtained from its first index. Set_Etype (N, Slice_Subtype); @@ -7523,8 +7985,8 @@ package body Sem_Res is (Subtype_Id, Make_Integer_Literal (Loc, 1)); Set_Etype (String_Literal_Low_Bound (Subtype_Id), Standard_Positive); - -- Build bona fide subtypes for the string, and wrap it in an - -- unchecked conversion, because the backend expects the + -- Build bona fide subtype for the string, and wrap it in an + -- unchecked conversion, because the backend expects the -- String_Literal_Subtype to have a static lower bound. declare @@ -7899,7 +8361,7 @@ package body Sem_Res is -- (RM 4.6(23)). elsif Is_Class_Wide_Type (Opnd_Type) - and then Covers (Opnd_Type, Target_Type) + and then Covers (Opnd_Type, Target_Type) then return True; @@ -7916,6 +8378,17 @@ package body Sem_Res is elsif Is_Interface (Target_Type) or else Is_Interface (Opnd_Type) then return True; + -- If the operand is a class-wide type obtained through a limited_ + -- with clause, and the context includes the non-limited view, use + -- it to determine whether the conversion is legal. + + elsif Is_Class_Wide_Type (Opnd_Type) + and then From_With_Type (Opnd_Type) + and then Present (Non_Limited_View (Etype (Opnd_Type))) + and then Is_Interface (Non_Limited_View (Etype (Opnd_Type))) + then + return True; + elsif Is_Access_Type (Opnd_Type) and then Is_Interface (Directly_Designated_Type (Opnd_Type)) then diff --git a/gcc/ada/sem_res.ads b/gcc/ada/sem_res.ads index b83be5d7416..33b9f404161 100644 --- a/gcc/ada/sem_res.ads +++ b/gcc/ada/sem_res.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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- -- @@ -93,6 +93,13 @@ package Sem_Res is -- is not present, then the Etype of the expression after the Analyze -- call is used for the Resolve. + procedure Ambiguous_Character (C : Node_Id); + -- Give list of candidate interpretations when a character literal cannot + -- be resolved, for example in a (useless) comparison such as 'A' = 'B'. + -- In Ada95 the literals in question can be of type Character or Wide_ + -- Character. In Ada2005 Wide_Wide_Character is also a candidate. The + -- node may also be overloaded with user-defined character types. + procedure Check_Parameterless_Call (N : Node_Id); -- Several forms of names can denote calls to entities without para- -- meters. The context determines whether the name denotes the entity