From 1486a00e3be13869fa6b38d75643df52499a535f Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 11 Apr 2013 12:49:20 +0200 Subject: [PATCH] [multiple changes] 2013-04-11 Hristian Kirtchev * exp_ch4.adb (Process_Transient_Object): Add new local variable Fin_Call. Remove and explain ??? comment. Use the Actions of logical operators "and then" and "or else" to insert the generated finalization call. 2013-04-11 Eric Botcazou * gnat_rm.texi: Fix typo. 2013-04-11 Ed Schonberg * sem_res.adb: Minor reformatting. From-SVN: r197767 --- gcc/ada/ChangeLog | 15 ++++ gcc/ada/exp_ch4.adb | 26 ++++-- gcc/ada/gnat_rm.texi | 2 +- gcc/ada/sem_res.adb | 232 ++++++++++++++++++++++++++------------------------- 4 files changed, 155 insertions(+), 120 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d93f15c..6089371 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,18 @@ +2013-04-11 Hristian Kirtchev + + * exp_ch4.adb (Process_Transient_Object): Add new + local variable Fin_Call. Remove and explain ??? comment. Use the + Actions of logical operators "and then" and "or else" to insert + the generated finalization call. + +2013-04-11 Eric Botcazou + + * gnat_rm.texi: Fix typo. + +2013-04-11 Ed Schonberg + + * sem_res.adb: Minor reformatting. + 2013-04-11 Robert Dewar * atree.h: Add declarations for Flag255-Flag289 Fix declaration diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 779466a..be011f8 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -5166,8 +5166,8 @@ package body Exp_Ch4 is if Nkind_In (Par, N_Assignment_Statement, N_Object_Declaration, N_Pragma, - N_Simple_Return_Statement, - N_Procedure_Call_Statement) + N_Procedure_Call_Statement, + N_Simple_Return_Statement) then return Par; @@ -5192,6 +5192,7 @@ package body Exp_Ch4 is Obj_Typ : constant Node_Id := Etype (Obj_Id); Desig_Typ : Entity_Id; Expr : Node_Id; + Fin_Call : Node_Id; Ptr_Id : Entity_Id; Temp_Id : Entity_Id; @@ -5244,9 +5245,12 @@ package body Exp_Ch4 is -- Step 3: Hook the transient object to the temporary - if Is_Access_Type (Obj_Typ) then + -- The use of unchecked conversion / unrestricted access is needed + -- to avoid an accessibility violation. Note that the finalization + -- code is structured in such a way that the "hook" is processed + -- only when it points to an existing object. - -- Why is this an unchecked conversion ??? + if Is_Access_Type (Obj_Typ) then Expr := Unchecked_Convert_To (Ptr_Id, New_Reference_To (Obj_Id, Loc)); else @@ -5282,7 +5286,7 @@ package body Exp_Ch4 is -- the return statement as this would make it unreachable. if Nkind (Context) /= N_Simple_Return_Statement then - Insert_Action_After (Context, + Fin_Call := Make_Implicit_If_Statement (Obj_Decl, Condition => Make_Op_Ne (Loc, @@ -5298,7 +5302,17 @@ package body Exp_Ch4 is Make_Assignment_Statement (Loc, Name => New_Reference_To (Temp_Id, Loc), - Expression => Make_Null (Loc))))); + Expression => Make_Null (Loc)))); + + -- Use the Actions list of logical operators when inserting the + -- finalization call. This ensures that all transient objects + -- are finalized after the operators are evaluated. + + if Nkind_In (Context, N_And_Then, N_Or_Else) then + Insert_Action (Context, Fin_Call); + else + Insert_Action_After (Context, Fin_Call); + end if; end if; end Process_Transient_Object; diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 386f351..e1356e5 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -4032,7 +4032,7 @@ earlier versions of the package body. Syntax: @smallexample @c ada -pragma No_Inline (NAME [, NAME]); +pragma No_Inline (NAME {, NAME}); @end smallexample @noindent diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index c43c4f6..338ff78 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -2060,11 +2060,18 @@ package body Sem_Res is Analyze_Dimension (N); return; - -- Return if type = Any_Type (previous error encountered). except that - -- a Raise_Expression node is OK: it is legitimately labeled this way - -- since it provides no information on the context. + -- A Raise_Expression takes its type from context. The expression + -- itself does not specify any possible interpretation. - elsif Etype (N) = Any_Type and then Nkind (N) /= N_Raise_Expression then + -- Seems confusing to set the Etype to Typ here, only to be overwritten + -- and set to Ctx_Type in the big case statement??? + + elsif Nkind (N) = N_Raise_Expression then + Set_Etype (N, Typ); + + -- Return if type = Any_Type (previous error encountered). + + elsif Etype (N) = Any_Type then Debug_A_Exit ("resolving ", N, " (done, Etype = Any_Type)"); return; end if; @@ -2301,9 +2308,8 @@ package body Sem_Res is and then Scope (It.Nam) = Standard_Standard then Error_Msg_N - ("\\possible interpretation as " & - "universal_fixed operation " & - "(RM 4.5.5 (19))", N); + ("\\possible interpretation as universal_fixed " + & "operation (RM 4.5.5 (19))", N); else Error_Msg_N ("\\possible interpretation (predefined)#!", N); @@ -2591,8 +2597,9 @@ package body Sem_Res is end if; Error_Msg_Node_2 := Typ; - Error_Msg_NE ("no visible interpretation of&" & - " matches expected type&", N, Subp_Name); + Error_Msg_NE + ("no visible interpretation of& " + & "matches expected type&", N, Subp_Name); end; if All_Errors_Mode then @@ -3520,8 +3527,8 @@ package body Sem_Res is 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); + ("view conversion between unrelated by reference " + & "array types not allowed (\'A'I-00246)", A); -- In Ada 2005 mode, check view conversion component -- type cannot be private, tagged, or volatile. Note @@ -3605,8 +3612,8 @@ package body Sem_Res is or else Is_Limited_Type (Etype (Expression (A)))) then Error_Msg_N - ("conversion between unrelated limited array types " & - "not allowed (\A\I-00246)", A); + ("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); @@ -4087,8 +4094,8 @@ package body Sem_Res is and then No (Non_Limited_View (Desig)) then Error_Msg_NE - ("premature use of incomplete type& " & - "in dispatching call", A, Desig); + ("premature use of incomplete type& " + & "in dispatching call", A, Desig); end if; end; end if; @@ -4323,8 +4330,8 @@ package body Sem_Res is (Etype (Pool), Name_Simple_Storage_Pool_Type)) then Error_Msg_N - ("limited function calls not yet supported in simple " & - "storage pool allocators", Expression (E)); + ("limited function calls not yet supported in simple " + & "storage pool allocators", Expression (E)); end if; end; end if; @@ -4471,10 +4478,11 @@ package body Sem_Res is Deepest_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); + 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)); @@ -4485,8 +4493,8 @@ package body Sem_Res is -- type. A run-time check will be performed in the instance. elsif not Is_Generic_Type (Exp_Typ) then - Error_Msg_N ("type in allocator has deeper level than" & - " designated class-wide type", E); + Error_Msg_N ("type in allocator has deeper level than " + & "designated class-wide type", E); end if; end if; end; @@ -5048,8 +5056,8 @@ package body Sem_Res is and then not Machine_Overflows_On_Target then Error_Msg_N - ("float division by zero, " & - "may generate '+'/'- infinity??", Right_Opnd (N)); + ("float division by zero, may generate " + & "'+'/'- infinity??", Right_Opnd (N)); -- For all other cases, we get a Constraint_Error @@ -9776,8 +9784,8 @@ package body Sem_Res is 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); + ("wrong interface conversion (% is not a progenitor " + & "of %)", N); end if; else @@ -10499,14 +10507,10 @@ package body Sem_Res is Msg : String) return Boolean; -- Little routine to post Msg if Valid is False, returns Valid value - -- The following are badly named, this kind of overloading is actively - -- confusing in reading code, please rename to something like - -- Error_Msg_N_If_Reporting ??? - - procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id); + procedure Conversion_Error_N (Msg : String; N : Node_Or_Entity_Id); -- If Report_Errs, then calls Errout.Error_Msg_N with its arguments - procedure Error_Msg_NE + procedure Conversion_Error_NE (Msg : String; N : Node_Or_Entity_Id; E : Node_Or_Entity_Id); @@ -10543,37 +10547,37 @@ package body Sem_Res is and then not In_Instance then - Error_Msg_N (Msg, Operand); + Conversion_Error_N (Msg, Operand); end if; return Valid; end Conversion_Check; - ----------------- - -- Error_Msg_N -- - ----------------- + ------------------------ + -- Conversion_Error_N -- + ------------------------ - procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id) is + procedure Conversion_Error_N (Msg : String; N : Node_Or_Entity_Id) is begin if Report_Errs then - Errout.Error_Msg_N (Msg, N); + Error_Msg_N (Msg, N); end if; - end Error_Msg_N; + end Conversion_Error_N; - ------------------ - -- Error_Msg_NE -- - ------------------ + ------------------------- + -- Conversion_Error_NE -- + ------------------------- - procedure Error_Msg_NE + procedure Conversion_Error_NE (Msg : String; N : Node_Or_Entity_Id; E : Node_Or_Entity_Id) is begin if Report_Errs then - Errout.Error_Msg_NE (Msg, N, E); + Error_Msg_NE (Msg, N, E); end if; - end Error_Msg_NE; + end Conversion_Error_NE; ---------------------------- -- Valid_Array_Conversion -- @@ -10601,7 +10605,7 @@ package body Sem_Res is if Number_Dimensions (Target_Type) /= Number_Dimensions (Opnd_Type) then - Error_Msg_N + Conversion_Error_N ("incompatible number of dimensions for conversion", Operand); return False; @@ -10623,7 +10627,7 @@ package body Sem_Res is and then (Root_Type (Target_Index_Type) /= Root_Type (Opnd_Index_Type)) then - Error_Msg_N + Conversion_Error_N ("incompatible index types for array conversion", Operand); return False; @@ -10657,10 +10661,10 @@ package body Sem_Res is Deepest_Type_Access_Level (Opnd_Type) then if In_Instance_Body then - Error_Msg_N - ("??source array type has " & - "deeper accessibility level than target", Operand); - Error_Msg_N + Conversion_Error_N + ("??source array type has deeper accesibility " + & "level than target", Operand); + Conversion_Error_N ("\??Program_Error will be raised at run time", Operand); Rewrite (N, @@ -10672,9 +10676,9 @@ package body Sem_Res is -- Conversion not allowed because of accessibility levels else - Error_Msg_N - ("source array type has " & - "deeper accessibility level than target", Operand); + Conversion_Error_N + ("source array type has deeper accessibility " + & "level than target", Operand); return False; end if; @@ -10685,7 +10689,7 @@ package body Sem_Res is -- All other cases where component base types do not match else - Error_Msg_N + Conversion_Error_N ("incompatible component types for array conversion", Operand); return False; @@ -10699,7 +10703,7 @@ package body Sem_Res is if not Subtypes_Statically_Match (Target_Comp_Type, Opnd_Comp_Type) then - Error_Msg_N + Conversion_Error_N ("component subtypes must statically match", Operand); return False; end if; @@ -10762,7 +10766,7 @@ package body Sem_Res is return True; else - Error_Msg_NE + Conversion_Error_NE ("invalid tagged conversion, not compatible with}", N, First_Subtype (Opnd_Type)); return False; @@ -10829,7 +10833,7 @@ package body Sem_Res is It1 := It; if No (It.Typ) then - Error_Msg_N ("illegal operand in conversion", Operand); + Conversion_Error_N ("illegal operand in conversion", Operand); return False; end if; @@ -10841,7 +10845,8 @@ package body Sem_Res is It1 := Disambiguate (Operand, I1, I, Any_Type); if It1 = No_Interp then - Error_Msg_N ("ambiguous operand in conversion", Operand); + Conversion_Error_N + ("ambiguous operand in conversion", Operand); -- If the interpretation involves a standard operator, use -- the location of the type, which may be user-defined. @@ -10852,7 +10857,7 @@ package body Sem_Res is Error_Msg_Sloc := Sloc (It.Nam); end if; - Error_Msg_N -- CODEFIX + Conversion_Error_N -- CODEFIX ("\\possible interpretation#!", Operand); if Sloc (N1) = Standard_Location then @@ -10861,7 +10866,7 @@ package body Sem_Res is Error_Msg_Sloc := Sloc (N1); end if; - Error_Msg_N -- CODEFIX + Conversion_Error_N -- CODEFIX ("\\possible interpretation#!", Operand); return False; @@ -10912,7 +10917,8 @@ package body Sem_Res is or else Opnd_Type = Any_Composite or else Opnd_Type = Any_String then - Error_Msg_N ("illegal operand for array conversion", Operand); + Conversion_Error_N + ("illegal operand for array conversion", Operand); return False; else return Valid_Array_Conversion; @@ -10944,14 +10950,14 @@ package body Sem_Res is -- will be generated by Expand_N_Type_Conversion. if In_Instance_Body then - Error_Msg_N + Conversion_Error_N ("??cannot convert local pointer to non-local access type", Operand); - Error_Msg_N + Conversion_Error_N ("\??Program_Error will be raised at run time", Operand); else - Error_Msg_N + Conversion_Error_N ("cannot convert local pointer to non-local access type", Operand); return False; @@ -10977,16 +10983,16 @@ package body Sem_Res is -- 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 + Conversion_Error_N + ("??cannot convert access discriminant to non-local " + & "access type", Operand); + Conversion_Error_N ("\??Program_Error will be raised at run time", Operand); else - Error_Msg_N - ("cannot convert access discriminant to non-local" & - " access type", Operand); + Conversion_Error_N + ("cannot convert access discriminant to non-local " + & "access type", Operand); return False; end if; end if; @@ -11003,7 +11009,7 @@ package body Sem_Res is Ekind_In (Entity (Operand), E_In_Parameter, E_Constant) and then Present (Discriminal_Link (Entity (Operand))) then - Error_Msg_N + Conversion_Error_N ("discriminant has deeper accessibility level than target", Operand); return False; @@ -11028,7 +11034,7 @@ package body Sem_Res is if Is_Access_Constant (Opnd_Type) and then not Is_Access_Constant (Target_Type) then - Error_Msg_N + Conversion_Error_N ("access-to-constant operand type not allowed", Operand); return False; end if; @@ -11068,9 +11074,9 @@ package body Sem_Res is if Nkind (Associated_Node_For_Itype (Opnd_Type)) = N_Object_Declaration then - Error_Msg_N - ("implicit conversion of stand-alone anonymous " & - "access object not allowed", Operand); + Conversion_Error_N + ("implicit conversion of stand-alone anonymous " + & "access object not allowed", Operand); return False; -- Implicit conversions aren't allowed for anonymous access @@ -11082,9 +11088,9 @@ package body Sem_Res is N_Function_Specification, N_Procedure_Specification) then - Error_Msg_N - ("implicit conversion of anonymous access formal " & - "not allowed", Operand); + Conversion_Error_N + ("implicit conversion of anonymous access formal " + & "not allowed", Operand); return False; -- This is a case where there's an enclosing object whose @@ -11095,9 +11101,9 @@ package body Sem_Res is elsif Object_Access_Level (Operand) = Scope_Depth (Standard_Standard) then - Error_Msg_N - ("implicit conversion of anonymous access value " & - "not allowed", Operand); + Conversion_Error_N + ("implicit conversion of anonymous access value " + & "not allowed", Operand); return False; -- In other cases, the level of the operand's type must be @@ -11107,9 +11113,9 @@ package body Sem_Res is elsif Type_Access_Level (Opnd_Type) > Deepest_Type_Access_Level (Target_Type) then - Error_Msg_N - ("implicit conversion of anonymous access value " & - "violates accessibility", Operand); + Conversion_Error_N + ("implicit conversion of anonymous access value " + & "violates accessibility", Operand); return False; end if; end if; @@ -11122,17 +11128,17 @@ package body Sem_Res is -- will be generated by Expand_N_Type_Conversion. if In_Instance_Body then - Error_Msg_N + Conversion_Error_N ("??cannot convert local pointer to non-local access type", Operand); - Error_Msg_N + Conversion_Error_N ("\??Program_Error will be raised at run time", Operand); else -- Avoid generation of spurious error message if not Error_Posted (N) then - Error_Msg_N + Conversion_Error_N ("cannot convert local pointer to non-local access type", Operand); end if; @@ -11160,17 +11166,17 @@ package body Sem_Res is -- 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 + Conversion_Error_N + ("??cannot convert access discriminant to non-local " + & "access type", Operand); + Conversion_Error_N ("\??Program_Error will be raised at run time", Operand); else - Error_Msg_N - ("cannot convert access discriminant to non-local" & - " access type", Operand); + Conversion_Error_N + ("cannot convert access discriminant to non-local " + & "access type", Operand); return False; end if; end if; @@ -11186,7 +11192,7 @@ package body Sem_Res is Ekind_In (Entity (Operand), E_In_Parameter, E_Constant) and then Present (Discriminal_Link (Entity (Operand))) then - Error_Msg_N + Conversion_Error_N ("discriminant has deeper accessibility level than target", Operand); return False; @@ -11237,7 +11243,7 @@ package body Sem_Res is else if not Same_Base then - Error_Msg_NE + Conversion_Error_NE ("target designated type not compatible with }", N, Base_Type (Opnd)); return False; @@ -11262,10 +11268,10 @@ package body Sem_Res is and then Known_Static_RM_Size (Opnd) and then RM_Size (Target) /= RM_Size (Opnd) then - Error_Msg_NE + Conversion_Error_NE ("target designated subtype not compatible with }", N, Opnd); - Error_Msg_NE + Conversion_Error_NE ("\because sizes of the two designated subtypes differ", N, Opnd); return False; @@ -11303,12 +11309,12 @@ package body Sem_Res is or else not Is_Entity_Name (Name (Parent (N))) or else not Is_Return_Object (Entity (Name (Parent (N))))) then - Error_Msg_N + Conversion_Error_N ("illegal attempt to store anonymous access to subprogram", Operand); - Error_Msg_N - ("\value has deeper accessibility than any master " & - "(RM 3.10.2 (13))", + Conversion_Error_N + ("\value has deeper accessibility than any master " + & "(RM 3.10.2 (13))", Operand); Error_Msg_NE @@ -11327,7 +11333,7 @@ package body Sem_Res is if Type_Access_Level (Opnd_Type) > Deepest_Type_Access_Level (Target_Type) then - Error_Msg_N + Conversion_Error_N ("operand type has deeper accessibility level than target", Operand); @@ -11349,9 +11355,9 @@ package body Sem_Res is end loop; if T_Gen /= O_Gen then - Error_Msg_N - ("target type must be declared in same generic body" - & " as operand type", N); + Conversion_Error_N + ("target type must be declared in same generic body " + & "as operand type", N); end if; end; end if; @@ -11408,14 +11414,14 @@ package body Sem_Res is elsif Ekind (Target_Type) = E_Access_Type and then Is_Access_Type (Opnd_Type) then - Error_Msg_N ("target type must be general access type!", N); - Error_Msg_NE -- CODEFIX + Conversion_Error_N ("target type must be general access type!", N); + Conversion_Error_NE -- CODEFIX ("add ALL to }!", N, Target_Type); return False; else - Error_Msg_NE ("invalid conversion, not compatible with }", - N, Opnd_Type); + Conversion_Error_NE + ("invalid conversion, not compatible with }", N, Opnd_Type); return False; end if; end Valid_Conversion; -- 2.7.4