From 1f09ee4a54bca320e5f6c21a76ee18f1fa899c41 Mon Sep 17 00:00:00 2001 From: charlet Date: Tue, 14 Aug 2007 08:47:12 +0000 Subject: [PATCH] 2007-08-14 Ed Schonberg Hristian Kirtchev * sem_res.adb (Resolve_Allocator): Propagate any coextensions that appear in the subtree to the current allocator if it is not a static coextension. (Resolve_Allocator): Perform cleanup if resolution has determined that the allocator is not a coextension. (Resolve): Skip an interpretation hidden by an abstract operator only when the type of the interpretation matches that of the context. (Resolve): When looping through all possible interpretations of a node, do not consider those that are hidden by abstract operators. (Resolve_Actuals): When verifying that an access to class-wide object is an actual for a controlling formal, ignore anonymous access to subprograms whose return type is an access to class_wide type. (Resolve_Slice): If the prefix of the slice is a selected component whose type depends on discriminants, build its actual subtype before applying range checks on the bounds of the slice. (Valid_Conversion): In an instance or inlined body, compare root types, to prevent anomalies between private and public views. (Resolve): Improve error message for ambiguous fixed multiplication expressions that involve universal_fixed multiplying operations. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@127447 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/sem_res.adb | 241 ++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 167 insertions(+), 74 deletions(-) diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index a2b8b23..94a57c9 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -522,7 +522,7 @@ package body Sem_Res is -- Warn about the danger Error_Msg_N - ("creation of & object may raise Storage_Error?", + ("?creation of & object may raise Storage_Error!", Scope (Disc)); <> @@ -732,7 +732,7 @@ package body Sem_Res is -- for generating a stub function - if Nkind (Parent (N)) = N_Return_Statement + if Nkind (Parent (N)) = N_Simple_Return_Statement and then Same_Argument_List then exit when not Is_List_Member (Parent (N)); @@ -768,8 +768,8 @@ package body Sem_Res is end if; end loop; - Error_Msg_N ("possible infinite recursion?", N); - Error_Msg_N ("\Storage_Error may be raised at run time?", N); + Error_Msg_N ("!?possible infinite recursion", N); + Error_Msg_N ("\!?Storage_Error may be raised at run time", N); return True; end Check_Infinite_Recursion; @@ -793,29 +793,42 @@ package body Sem_Res is ------------- function Uses_SS (T : Entity_Id) return Boolean is - Comp : Entity_Id; - Expr : Node_Id; + Comp : Entity_Id; + Expr : Node_Id; + Full_Type : Entity_Id := Underlying_Type (T); begin - if Is_Controlled (T) then + -- Normally we want to use the underlying type, but if it's not set + -- then continue with T. + + if not Present (Full_Type) then + Full_Type := T; + end if; + + if Is_Controlled (Full_Type) then return False; - elsif Is_Array_Type (T) then - return Uses_SS (Component_Type (T)); + elsif Is_Array_Type (Full_Type) then + return Uses_SS (Component_Type (Full_Type)); - elsif Is_Record_Type (T) then - Comp := First_Component (T); + elsif Is_Record_Type (Full_Type) then + Comp := First_Component (Full_Type); while Present (Comp) loop if Ekind (Comp) = E_Component and then Nkind (Parent (Comp)) = N_Component_Declaration then - Expr := Expression (Parent (Comp)); + -- The expression for a dynamic component may be rewritten + -- as a dereference, so retrieve original node. + + Expr := Original_Node (Expression (Parent (Comp))); - -- The expression for a dynamic component may be - -- rewritten as a dereference. Retrieve original - -- call. + -- Return True if the expression is a call to a function + -- (including an attribute function such as Image) with + -- a result that requires a transient scope. - if Nkind (Original_Node (Expr)) = N_Function_Call + if (Nkind (Expr) = N_Function_Call + or else (Nkind (Expr) = N_Attribute_Reference + and then Present (Expressions (Expr)))) and then Requires_Transient_Scope (Etype (Expr)) then return True; @@ -1374,23 +1387,40 @@ package body Sem_Res is begin if Is_Binary then - if Op_Name = Name_Op_And then Kind := N_Op_And; - elsif Op_Name = Name_Op_Or then Kind := N_Op_Or; - elsif Op_Name = Name_Op_Xor then Kind := N_Op_Xor; - elsif Op_Name = Name_Op_Eq then Kind := N_Op_Eq; - elsif Op_Name = Name_Op_Ne then Kind := N_Op_Ne; - elsif Op_Name = Name_Op_Lt then Kind := N_Op_Lt; - elsif Op_Name = Name_Op_Le then Kind := N_Op_Le; - elsif Op_Name = Name_Op_Gt then Kind := N_Op_Gt; - elsif Op_Name = Name_Op_Ge then Kind := N_Op_Ge; - elsif Op_Name = Name_Op_Add then Kind := N_Op_Add; - elsif Op_Name = Name_Op_Subtract then Kind := N_Op_Subtract; - elsif Op_Name = Name_Op_Concat then Kind := N_Op_Concat; - elsif Op_Name = Name_Op_Multiply then Kind := N_Op_Multiply; - elsif Op_Name = Name_Op_Divide then Kind := N_Op_Divide; - elsif Op_Name = Name_Op_Mod then Kind := N_Op_Mod; - elsif Op_Name = Name_Op_Rem then Kind := N_Op_Rem; - elsif Op_Name = Name_Op_Expon then Kind := N_Op_Expon; + if Op_Name = Name_Op_And then + Kind := N_Op_And; + elsif Op_Name = Name_Op_Or then + Kind := N_Op_Or; + elsif Op_Name = Name_Op_Xor then + Kind := N_Op_Xor; + elsif Op_Name = Name_Op_Eq then + Kind := N_Op_Eq; + elsif Op_Name = Name_Op_Ne then + Kind := N_Op_Ne; + elsif Op_Name = Name_Op_Lt then + Kind := N_Op_Lt; + elsif Op_Name = Name_Op_Le then + Kind := N_Op_Le; + elsif Op_Name = Name_Op_Gt then + Kind := N_Op_Gt; + elsif Op_Name = Name_Op_Ge then + Kind := N_Op_Ge; + elsif Op_Name = Name_Op_Add then + Kind := N_Op_Add; + elsif Op_Name = Name_Op_Subtract then + Kind := N_Op_Subtract; + elsif Op_Name = Name_Op_Concat then + Kind := N_Op_Concat; + elsif Op_Name = Name_Op_Multiply then + Kind := N_Op_Multiply; + elsif Op_Name = Name_Op_Divide then + Kind := N_Op_Divide; + elsif Op_Name = Name_Op_Mod then + Kind := N_Op_Mod; + elsif Op_Name = Name_Op_Rem then + Kind := N_Op_Rem; + elsif Op_Name = Name_Op_Expon then + Kind := N_Op_Expon; else raise Program_Error; end if; @@ -1398,10 +1428,14 @@ package body Sem_Res is -- Unary operators else - if Op_Name = Name_Op_Add then Kind := N_Op_Plus; - elsif Op_Name = Name_Op_Subtract then Kind := N_Op_Minus; - elsif Op_Name = Name_Op_Abs then Kind := N_Op_Abs; - elsif Op_Name = Name_Op_Not then Kind := N_Op_Not; + if Op_Name = Name_Op_Add then + Kind := N_Op_Plus; + elsif Op_Name = Name_Op_Subtract then + Kind := N_Op_Minus; + elsif Op_Name = Name_Op_Abs then + Kind := N_Op_Abs; + elsif Op_Name = Name_Op_Not then + Kind := N_Op_Not; else raise Program_Error; end if; @@ -1746,7 +1780,7 @@ package body Sem_Res is Interp_Loop : while Present (It.Typ) loop -- We are only interested in interpretations that are compatible - -- with the expected type, any other interpretations are ignored + -- with the expected type, any other interpretations are ignored. if not Covers (Typ, It.Typ) then if Debug_Flag_V then @@ -1755,6 +1789,20 @@ package body Sem_Res is end if; else + -- Skip the current interpretation if it is disabled by an + -- abstract operator. This action is performed only when the + -- type against which we are resolving is the same as the + -- type of the interpretation. + + if Ada_Version >= Ada_05 + and then It.Typ = Typ + and then Typ /= Universal_Integer + and then Typ /= Universal_Real + and then Present (It.Abstract_Op) + then + goto Continue; + end if; + -- First matching interpretation if not Found then @@ -1818,7 +1866,7 @@ package body Sem_Res is end loop; end; - elsif Nkind (N) in N_Binary_Op + elsif Nkind (N) in N_Binary_Op and then (Etype (Left_Opnd (N)) = Any_Type or else Etype (Right_Opnd (N)) = Any_Type) then @@ -1913,8 +1961,21 @@ package body Sem_Res is and then Scope (It.Nam) = Standard_Standard and then Present (Err_Type) then - Error_Msg_N - ("\\possible interpretation (predefined)#!", N); + -- Special-case the message for universal_fixed + -- operators, which are not declared with the type + -- of the operand, but appear forever in Standard. + + if It.Typ = Universal_Fixed + and then Scope (It.Nam) = Standard_Standard + then + Error_Msg_N + ("\\possible interpretation as " & + "universal_fixed operation " & + "(RM 4.5.5 (19))", N); + else + Error_Msg_N + ("\\possible interpretation (predefined)#!", N); + end if; elsif Nkind (Parent (It.Nam)) = N_Full_Type_Declaration @@ -1985,6 +2046,8 @@ package body Sem_Res is end if; + <> + -- Move to next interpretation exit Interp_Loop when No (It.Typ); @@ -2190,11 +2253,13 @@ package body Sem_Res is Get_First_Interp (Name (N), Index, It); while Present (It.Nam) loop Error_Msg_Sloc := Sloc (It.Nam); - Error_Msg_Node_2 := It.Typ; - Error_Msg_NE ("\& declared#, type&", N, It.Nam); + Error_Msg_Node_2 := It.Nam; + Error_Msg_NE + ("\\ type& for & declared#", N, It.Typ); Get_Next_Interp (Index, It); end loop; end; + else Error_Msg_N ("\use -gnatf for details", N); end if; @@ -2534,7 +2599,7 @@ package body Sem_Res is 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))", + & " (RM-2005 4.3.1 (13))", Prefix (Act), Nam); end if; @@ -3012,11 +3077,11 @@ package body Sem_Res is 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 + and then Known_Null (A) then Apply_Compile_Time_Constraint_Error (N => A, - Msg => "(Ada 2005) NULL not allowed in " + Msg => "(Ada 2005) null not allowed in " & "null-excluding formal?", Reason => CE_Null_Not_Allowed); end if; @@ -3127,6 +3192,7 @@ package body Sem_Res is elsif Is_Access_Type (A_Typ) and then Is_Access_Type (F_Typ) and then Ekind (F_Typ) /= E_Access_Subprogram_Type + and then Ekind (F_Typ) /= E_Anonymous_Access_Subprogram_Type and then (Is_Class_Wide_Type (Designated_Type (A_Typ)) or else (Nkind (A) = N_Attribute_Reference and then @@ -3634,8 +3700,8 @@ package body Sem_Res is declare Loc : constant Source_Ptr := Sloc (N); begin - Error_Msg_N ("?allocation from empty storage pool", N); - Error_Msg_N ("\?Storage_Error will be raised at run time", N); + Error_Msg_N ("?allocation from empty storage pool!", N); + Error_Msg_N ("\?Storage_Error will be raised at run time!", N); Insert_Action (N, Make_Raise_Storage_Error (Loc, Reason => SE_Empty_Storage_Pool)); @@ -3659,26 +3725,32 @@ package body Sem_Res is if Nkind (N) = N_Allocator then -- An anonymous access discriminant is the definition of a - -- coextension + -- 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. + -- within a static construct. if not Is_Static_Coextension (N) then - Set_Is_Coextension (N); + Set_Is_Dynamic_Coextension (N); end if; -- Cleanup for potential static coextensions else - Set_Is_Static_Coextension (N, False); + Set_Is_Dynamic_Coextension (N, False); + Set_Is_Static_Coextension (N, False); end if; - Propagate_Coextensions (N); + -- There is no need to propagate any nested coextensions if they + -- are marked as static since they will be rewritten on the spot. + + if not Is_Static_Coextension (N) then + Propagate_Coextensions (N); + end if; end if; end Resolve_Allocator; @@ -4269,7 +4341,7 @@ package body Sem_Res is then Rtype := Etype (N); Error_Msg_NE - ("& should not be used in entry body ('R'M C.7(17))?", + ("?& should not be used in entry body (RM C.7(17))", N, Nam); Error_Msg_NE ("\Program_Error will be raised at run time?", N, Nam); @@ -4535,9 +4607,9 @@ package body Sem_Res is Set_Has_Recursive_Call (Nam); Error_Msg_N - ("possible infinite recursion?", N); + ("?possible infinite recursion!", N); Error_Msg_N - ("\Storage_Error may be raised at run time?", N); + ("\?Storage_Error may be raised at run time!", N); end if; exit Scope_Loop; @@ -5485,10 +5557,8 @@ package body Sem_Res is begin if Ekind (Etype (R)) = E_Allocator_Type then Acc := Designated_Type (Etype (R)); - elsif Ekind (Etype (L)) = E_Allocator_Type then Acc := Designated_Type (Etype (L)); - else return Empty; end if; @@ -5568,7 +5638,7 @@ package body Sem_Res is and then Entity (R) = Standard_True and then Comes_From_Source (R) then - Error_Msg_N ("comparison with True is redundant?", R); + Error_Msg_N ("?comparison with True is redundant!", R); end if; Check_Unset_Reference (L); @@ -6462,7 +6532,7 @@ package body Sem_Res is and then not Is_Boolean_Type (Typ) and then Parent_Is_Boolean then - Error_Msg_N ("?not expression should be parenthesized here", N); + Error_Msg_N ("?not expression should be parenthesized here!", N); end if; Resolve (Right_Opnd (N), B_Typ); @@ -6627,7 +6697,7 @@ package body Sem_Res is and then Warn_On_Bad_Fixed_Value then Error_Msg_N - ("static fixed-point value is not a multiple of Small?", + ("?static fixed-point value is not a multiple of Small!", N); end if; @@ -6992,6 +7062,23 @@ package body Sem_Res is and then not Is_Constrained (Etype (Name))) then Array_Type := Get_Actual_Subtype (Name); + + -- If the name is a selected component that depends on discriminants, + -- build an actual subtype for it. This can happen only when the name + -- itself is overloaded; otherwise the actual subtype is created when + -- the selected component is analyzed. + + elsif Nkind (Name) = N_Selected_Component + and then Full_Analysis + and then Depends_On_Discriminant (First_Index (Array_Type)) + then + declare + Act_Decl : constant Node_Id := + Build_Actual_Subtype_Of_Component (Array_Type, Name); + begin + Insert_Action (N, Act_Decl); + Array_Type := Defining_Identifier (Act_Decl); + end; end if; -- If name was overloaded, set slice type correctly now @@ -7368,11 +7455,11 @@ package body Sem_Res is and then abs (Realval (Rop)) < Delta_Value (Standard_Duration) then Error_Msg_N - ("universal real operand can only " & - "be interpreted as Duration?", + ("?universal real operand can only " & + "be interpreted as Duration!", Rop); Error_Msg_N - ("\precision will be lost in the conversion", Rop); + ("\?precision will be lost in the conversion!", Rop); end if; elsif Is_Numeric_Type (Typ) @@ -7452,7 +7539,7 @@ package body Sem_Res is and then Etype (Entity (Orig_N)) = Orig_T then Error_Msg_NE - ("?useless conversion, & has this type", N, Entity (Orig_N)); + ("?useless conversion, & has this type!", N, Entity (Orig_N)); end if; end if; @@ -7494,7 +7581,11 @@ package body Sem_Res is ("type conversions require visibility of the full view", N); - elsif From_With_Type (Target) then + elsif From_With_Type (Target) + and then not + (Is_Access_Type (Target_Typ) + and then Present (Non_Limited_View (Etype (Target)))) + then Error_Msg_Qual_Level := 99; Error_Msg_NE ("missing with-clause on package &", N, Cunit_Entity (Get_Source_Unit (Base_Type (Target)))); @@ -7735,7 +7826,7 @@ package body Sem_Res is -- If we fall through warning should be issued Error_Msg_N - ("?unary minus expression should be parenthesized here", N); + ("?unary minus expression should be parenthesized here!", N); end if; end if; end; @@ -8161,10 +8252,10 @@ package body Sem_Res is end loop; if Nkind (N) = N_Real_Literal then - Error_Msg_NE ("real literal interpreted as }?", N, T1); + Error_Msg_NE ("?real literal interpreted as }!", N, T1); else - Error_Msg_NE ("universal_fixed expression interpreted as }?", N, T1); + Error_Msg_NE ("?universal_fixed expression interpreted as }!", N, T1); end if; return T1; @@ -8803,7 +8894,7 @@ package body Sem_Res is Operand); Error_Msg_N ("\value has deeper accessibility than any master " & - "('R'M 3.10.2 (13))", + "(RM 3.10.2 (13))", Operand); if Is_Entity_Name (Operand) @@ -8884,11 +8975,13 @@ package body Sem_Res is elsif Root_Type (Target_Type) = Root_Type (Opnd_Type) then return True; - -- In an instance, there may be inconsistent views of the same - -- type, or types derived from the same type. + -- In an instance or an inlined body, there may be inconsistent + -- views of the same type, or of types derived from a common root. - elsif In_Instance - and then Underlying_Type (Target_Type) = Underlying_Type (Opnd_Type) + elsif (In_Instance or In_Inlined_Body) + and then + Root_Type (Underlying_Type (Target_Type)) = + Root_Type (Underlying_Type (Opnd_Type)) then return True; -- 2.7.4