From: Arnaud Charlet Date: Thu, 4 Aug 2011 09:53:21 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=35a1c212918d3b4c0f0bb75a652038152e8396d1;p=gcc.git [multiple changes] 2011-08-04 Thomas Quinot * sinfo.adb, sinfo.ads, sem_prag.adb, sem_ch12.adb (Pragma_Enabled): This flag of N_Pragma nodes is not used, remove it as well as all of the associated circuitry. 2011-08-04 Javier Miranda * exp_disp.adb (Make_DT): Switch -gnatdQ disables the generation of the runtime check on duplicated externa tags * debug.adb Document switch -gnatdQ. 2011-08-04 Gary Dismukes * a-fihema.ads: Minor typo fix. 2011-08-04 Yannick Moy * sem_ch10.adb: Minor comment update. 2011-08-04 Hristian Kirtchev * einfo.adb: Update the node field usage to reflect the renaming of Return_Flag to Return_ Flag_Or_Transient_Decl. (Return_Flag): Renamed to Return_Flag_Or_Transient_Decl. (Set_Return_Flag): Renamed to Set_Return_Flag_Or_Transient_Decl. (Write_Field15_Name): Change Return_Flag to Return_Flag_Or_Transient_Decl. * einfo.ads: Rename node field Return_Flag to Return_Flag_Or_Transient_Decl. Update the associated comment and all occurrences in entities. (Return_Flag): Renamed to Return_Flag_Or_Transient_Decl. Update associated Inline pragma. (Set_Return_Flag): Renamed to Set_Return_Flag_Or_Transient_Decl. Update associated Inline pragma. * exp_ch4.ads, exp_ch4.adb (Expand_N_Expression_With_Actions): New routine. * exp_ch6.adb (Expand_N_Extended_Return_Statement): Update the calls to Return_Flag and Set_Return_Flag. * exp_ch7.adb (Process_Declarations): Add code to recognize hook objects generated for controlled transients declared inside an Exception_With_Actions. Update the calls to Return_Flag. (Process_Object_Declaration): Add code to add a null guard for hook objects generated for controlled transients declared inside an Exception_With_Actions. Update related comment. * exp_util.adb (Has_Controlled_Objects): Add code to recognize hook objects generated for controlled transients declared inside an Exception_With_Actions. Update the calls to Return_Flag. * expander.adb (Expand): Add new case for N_Expression_With_Actions. 2011-08-04 Ed Schonberg * sem_util.adb:(Wrong_Type): Improve error message on a one-element positional aggregate. 2011-08-04 Vincent Celier * par_sco.adb (Process_Decisions.Output_Header): Check and record pragma SLOC only for pragmas. 2011-08-04 Emmanuel Briot * projects.texi: Minor typo fix. 2011-08-04 Emmanuel Briot * prj-nmsc.adb (Check_File): Minor change to traces, to help debugging on case-sensitive file systems. From-SVN: r177349 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 402aec6ef0a..b90a4acf390 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,72 @@ +2011-08-04 Thomas Quinot + + * sinfo.adb, sinfo.ads, sem_prag.adb, sem_ch12.adb (Pragma_Enabled): + This flag of N_Pragma nodes is not used, remove it as well as all of + the associated circuitry. + +2011-08-04 Javier Miranda + + * exp_disp.adb (Make_DT): Switch -gnatdQ disables the generation of the + runtime check on duplicated externa tags + * debug.adb Document switch -gnatdQ. + +2011-08-04 Gary Dismukes + + * a-fihema.ads: Minor typo fix. + +2011-08-04 Yannick Moy + + * sem_ch10.adb: Minor comment update. + +2011-08-04 Hristian Kirtchev + + * einfo.adb: Update the node field usage to reflect the renaming of + Return_Flag to Return_ Flag_Or_Transient_Decl. + (Return_Flag): Renamed to Return_Flag_Or_Transient_Decl. + (Set_Return_Flag): Renamed to Set_Return_Flag_Or_Transient_Decl. + (Write_Field15_Name): Change Return_Flag to + Return_Flag_Or_Transient_Decl. + * einfo.ads: Rename node field Return_Flag to + Return_Flag_Or_Transient_Decl. Update the associated comment and all + occurrences in entities. + (Return_Flag): Renamed to Return_Flag_Or_Transient_Decl. Update + associated Inline pragma. + (Set_Return_Flag): Renamed to Set_Return_Flag_Or_Transient_Decl. Update + associated Inline pragma. + * exp_ch4.ads, exp_ch4.adb (Expand_N_Expression_With_Actions): New + routine. + * exp_ch6.adb (Expand_N_Extended_Return_Statement): Update the calls to + Return_Flag and Set_Return_Flag. + * exp_ch7.adb (Process_Declarations): Add code to recognize hook + objects generated for controlled transients declared inside an + Exception_With_Actions. Update the calls to Return_Flag. + (Process_Object_Declaration): Add code to add a null guard for hook + objects generated for controlled transients declared inside an + Exception_With_Actions. Update related comment. + * exp_util.adb (Has_Controlled_Objects): Add code to recognize hook + objects generated for controlled transients declared inside an + Exception_With_Actions. Update the calls to Return_Flag. + * expander.adb (Expand): Add new case for N_Expression_With_Actions. + +2011-08-04 Ed Schonberg + + * sem_util.adb:(Wrong_Type): Improve error message on a one-element + positional aggregate. + +2011-08-04 Vincent Celier + + * par_sco.adb (Process_Decisions.Output_Header): Check and record pragma + SLOC only for pragmas. + +2011-08-04 Emmanuel Briot + + * projects.texi: Minor typo fix. + +2011-08-04 Emmanuel Briot + + * prj-nmsc.adb (Check_File): Minor change to traces, to help debugging + on case-sensitive file systems. + 2011-08-04 Thomas Quinot * put_scos.adb (Put_SCOs): Do not emit decision SCO for an X decision diff --git a/gcc/ada/a-fihema.ads b/gcc/ada/a-fihema.ads index 028d77189a2..df0afa20639 100644 --- a/gcc/ada/a-fihema.ads +++ b/gcc/ada/a-fihema.ads @@ -133,7 +133,7 @@ private Finalize_Address : Finalize_Address_Ptr; -- A reference to a routine which finalizes an object denoted by its - -- address. The collection must be homogenious since the same routine + -- address. The collection must be homogeneous since the same routine -- will be invoked for every allocated object when the pool is -- finalized. diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 65af4de796d..35d1cedaf31 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -80,7 +80,7 @@ package body Debug is -- dN No file name information in exception messages -- dO Output immediate error messages -- dP Do not check for controlled objects in preelaborable packages - -- dQ + -- dQ Do not generate runtime check for duplicated external tag -- dR Bypass check for correct version of s-rpc -- dS Never convert numbers to machine numbers in Sem_Eval -- dT Convert to machine numbers only for constant declarations @@ -428,6 +428,12 @@ package body Debug is -- in preelaborable packages, but this restriction is a huge pain, -- especially in the predefined library units. + -- dQ Eliminate check for duplicate external tags. This check was added + -- for GNAT 6.4.1, and causes some backward compatibility problems. + -- It is never legitimate to have duplicate external tags, so the + -- check is certainly valid, but this debug switch can be useful for + -- enabling previous behavior of ignoring this problem. + -- dR Bypass the check for a proper version of s-rpc being present -- to use the -gnatz? switch. This allows debugging of the use -- of stubs generation without needing to have GLADE (or some diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 84163c67c8d..f0f0904b5e7 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -123,7 +123,7 @@ package body Einfo is -- Extra_Formal Node15 -- Lit_Indexes Node15 -- Related_Instance Node15 - -- Return_Flag Node15 + -- Return_Flag_Or_Transient_Decl Node15 -- Scale_Value Uint15 -- Storage_Size_Variable Node15 -- String_Literal_Low_Bound Node15 @@ -2559,11 +2559,11 @@ package body Einfo is return Flag213 (Id); end Requires_Overriding; - function Return_Flag (Id : E) return N is + function Return_Flag_Or_Transient_Decl (Id : E) return N is begin pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); return Node15 (Id); - end Return_Flag; + end Return_Flag_Or_Transient_Decl; function Return_Present (Id : E) return B is begin @@ -5101,11 +5101,11 @@ package body Einfo is Set_Flag213 (Id, V); end Set_Requires_Overriding; - procedure Set_Return_Flag (Id : E; V : E) is + procedure Set_Return_Flag_Or_Transient_Decl (Id : E; V : E) is begin pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); Set_Node15 (Id, V); - end Set_Return_Flag; + end Set_Return_Flag_Or_Transient_Decl; procedure Set_Return_Present (Id : E; V : B := True) is begin @@ -8130,7 +8130,7 @@ package body Einfo is when E_Constant | E_Variable => - Write_Str ("Return_Flag"); + Write_Str ("Return_Flag_Or_Transient_Decl"); when Decimal_Fixed_Point_Kind => Write_Str ("Scale_Value"); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 49e22fb01f9..23d3c3b42a8 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -3494,11 +3494,14 @@ package Einfo is -- is True only for implicitly declare subprograms; it is not set on the -- parent type's subprogram. See also Is_Abstract_Subprogram. --- Return_Flag (Node15) +-- Return_Flag_Or_Transient_Decl (Node15) -- Applies to variables and constants. Set for objects which act as the -- return value of an extended return statement. The node contains the -- entity of a locally declared flag which controls the finalization of --- the return object should the function fail. +-- the return object should the function fail. Also set for access-to- +-- controlled objects used to provide a hook to controlled transients +-- declared inside an Expression_With_Actions. The node contains the +-- object declaration of the controlled transient. -- Return_Present (Flag54) -- Present in function and generic function entities. Set if the @@ -5064,7 +5067,7 @@ package Einfo is -- Full_View (Node11) -- Esize (Uint12) -- Alignment (Uint14) - -- Return_Flag (Node15) (constants only) + -- Return_Flag_Or_Transient_Decl (Node15) (constants only) -- Actual_Subtype (Node17) -- Renamed_Object (Node18) -- Size_Check_Code (Node19) (constants only) @@ -5710,7 +5713,7 @@ package Einfo is -- Esize (Uint12) -- Extra_Accessibility (Node13) -- Alignment (Uint14) - -- Return_Flag (Node15) (transient object only) + -- Return_Flag_Or_Transient_Decl (Node15) (transient object only) -- Unset_Reference (Node16) -- Actual_Subtype (Node17) -- Renamed_Object (Node18) @@ -6328,7 +6331,7 @@ package Einfo is function Renamed_Object (Id : E) return N; function Renaming_Map (Id : E) return U; function Requires_Overriding (Id : E) return B; - function Return_Flag (Id : E) return E; + function Return_Flag_Or_Transient_Decl (Id : E) return E; function Return_Present (Id : E) return B; function Return_Applies_To (Id : E) return N; function Returns_By_Ref (Id : E) return B; @@ -6924,7 +6927,7 @@ package Einfo is procedure Set_Renamed_Object (Id : E; V : N); procedure Set_Renaming_Map (Id : E; V : U); procedure Set_Requires_Overriding (Id : E; V : B := True); - procedure Set_Return_Flag (Id : E; V : E); + procedure Set_Return_Flag_Or_Transient_Decl (Id : E; V : E); procedure Set_Return_Present (Id : E; V : B := True); procedure Set_Return_Applies_To (Id : E; V : N); procedure Set_Returns_By_Ref (Id : E; V : B := True); @@ -7663,7 +7666,7 @@ package Einfo is pragma Inline (Renamed_Object); pragma Inline (Renaming_Map); pragma Inline (Requires_Overriding); - pragma Inline (Return_Flag); + pragma Inline (Return_Flag_Or_Transient_Decl); pragma Inline (Return_Present); pragma Inline (Return_Applies_To); pragma Inline (Returns_By_Ref); @@ -8063,7 +8066,7 @@ package Einfo is pragma Inline (Set_Renamed_Object); pragma Inline (Set_Renaming_Map); pragma Inline (Set_Requires_Overriding); - pragma Inline (Set_Return_Flag); + pragma Inline (Set_Return_Flag_Or_Transient_Decl); pragma Inline (Set_Return_Present); pragma Inline (Set_Return_Applies_To); pragma Inline (Set_Returns_By_Ref); diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 2444e60004b..afe0c06111d 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -4302,6 +4302,126 @@ package body Exp_Ch4 is Insert_Dereference_Action (Prefix (N)); end Expand_N_Explicit_Dereference; + -------------------------------------- + -- Expand_N_Expression_With_Actions -- + -------------------------------------- + + procedure Expand_N_Expression_With_Actions (N : Node_Id) is + + procedure Process_Transient_Object (Decl : Node_Id); + -- Given the declaration of a controlled transient declared inside the + -- Actions list of an Expression_With_Actions, generate all necessary + -- types and hooks in order to properly finalize the transient. This + -- mechanism works in conjunction with Build_Finalizer. + + ------------------------------ + -- Process_Transient_Object -- + ------------------------------ + + procedure Process_Transient_Object (Decl : Node_Id) is + Ins_Nod : constant Node_Id := Parent (N); + -- To avoid the insertion of generated code in the list of Actions, + -- Insert_Action must look at the parent field of the EWA. + + Loc : constant Source_Ptr := Sloc (Decl); + Obj_Id : constant Entity_Id := Defining_Identifier (Decl); + Obj_Typ : constant Entity_Id := Etype (Obj_Id); + Desig_Typ : Entity_Id; + Expr : Node_Id; + Ptr_Decl : Node_Id; + Ptr_Id : Entity_Id; + Temp_Decl : Node_Id; + Temp_Id : Node_Id; + + begin + -- Step 1: Create the access type which provides a reference to + -- the transient object. + + if Is_Access_Type (Obj_Typ) then + Desig_Typ := Directly_Designated_Type (Obj_Typ); + else + Desig_Typ := Obj_Typ; + end if; + + -- Generate: + -- Ann : access [all] ; + + Ptr_Id := Make_Temporary (Loc, 'A'); + + Ptr_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Ptr_Id, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => + Ekind (Obj_Typ) = E_General_Access_Type, + Subtype_Indication => + New_Reference_To (Desig_Typ, Loc))); + + Insert_Action (Ins_Nod, Ptr_Decl); + Analyze (Ptr_Decl); + + -- Step 2: Create a temporary which acts as a hook to the transient + -- object. Generate: + + -- Temp : Ptr_Id := null; + + Temp_Id := Make_Temporary (Loc, 'T'); + + Temp_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp_Id, + Object_Definition => New_Reference_To (Ptr_Id, Loc)); + + Insert_Action (Ins_Nod, Temp_Decl); + Analyze (Temp_Decl); + + -- Mark this temporary as created for the purposes of "exporting" the + -- transient declaration out of the Actions list. This signals the + -- machinery in Build_Finalizer to recognize this special case. + + Set_Return_Flag_Or_Transient_Decl (Temp_Id, Decl); + + -- Step 3: "Hook" the transient object to the temporary + + if Is_Access_Type (Obj_Typ) then + Expr := Convert_To (Ptr_Id, New_Reference_To (Obj_Id, Loc)); + else + Expr := + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (Obj_Id, Loc), + Attribute_Name => Name_Unrestricted_Access); + end if; + + -- Generate: + -- Temp := Ptr_Id (Obj_Id); + -- + -- Temp := Obj_Id'Unrestricted_Access; + + Insert_After_And_Analyze (Decl, + Make_Assignment_Statement (Loc, + Name => New_Reference_To (Temp_Id, Loc), + Expression => Expr)); + end Process_Transient_Object; + + Decl : Node_Id; + + -- Start of processing for Expand_N_Expression_With_Actions + + begin + Decl := First (Actions (N)); + while Present (Decl) loop + if Nkind (Decl) = N_Object_Declaration + and then Is_Finalizable_Transient (Decl, N) + then + Process_Transient_Object (Decl); + end if; + + Next (Decl); + end loop; + end Expand_N_Expression_With_Actions; + ----------------- -- Expand_N_In -- ----------------- diff --git a/gcc/ada/exp_ch4.ads b/gcc/ada/exp_ch4.ads index 804365806a6..17323f249be 100644 --- a/gcc/ada/exp_ch4.ads +++ b/gcc/ada/exp_ch4.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, 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- -- @@ -34,6 +34,7 @@ package Exp_Ch4 is procedure Expand_N_Case_Expression (N : Node_Id); procedure Expand_N_Conditional_Expression (N : Node_Id); procedure Expand_N_Explicit_Dereference (N : Node_Id); + procedure Expand_N_Expression_With_Actions (N : Node_Id); procedure Expand_N_In (N : Node_Id); procedure Expand_N_Indexed_Component (N : Node_Id); procedure Expand_N_Not_In (N : Node_Id); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index ca449fae78b..9fda91c79cc 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -4649,7 +4649,7 @@ package body Exp_Ch6 is -- Create a flag to track the function state Flag_Id := Make_Temporary (Loc, 'F'); - Set_Return_Flag (Ret_Obj_Id, Flag_Id); + Set_Return_Flag_Or_Transient_Decl (Ret_Obj_Id, Flag_Id); -- Insert the flag at the beginning of the function declarations, -- generate: @@ -4713,8 +4713,8 @@ package body Exp_Ch6 is and then Needs_Finalization (Etype (Ret_Obj_Id)) then declare - Flag_Id : constant Entity_Id := Return_Flag (Ret_Obj_Id); - + Flag_Id : constant Entity_Id := + Return_Flag_Or_Transient_Decl (Ret_Obj_Id); begin -- Generate: -- Fnn := True; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index f79520edc22..54436913fb4 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -1785,6 +1785,15 @@ package body Exp_Ch7 is then Processing_Actions (Has_No_Init => True); + elsif Is_Access_Type (Obj_Typ) + and then Present (Return_Flag_Or_Transient_Decl (Obj_Id)) + and then Nkind (Return_Flag_Or_Transient_Decl (Obj_Id)) = + N_Object_Declaration + and then Is_Finalizable_Transient + (Return_Flag_Or_Transient_Decl (Obj_Id), Decl) + then + Processing_Actions (Has_No_Init => True); + -- Simple protected objects which use type System.Tasking. -- Protected_Objects.Protection to manage their locks should -- be treated as controlled since they require manual cleanup. @@ -1850,7 +1859,7 @@ package body Exp_Ch7 is elsif Needs_Finalization (Obj_Typ) and then Is_Return_Object (Obj_Id) - and then Present (Return_Flag (Obj_Id)) + and then Present (Return_Flag_Or_Transient_Decl (Obj_Id)) then Processing_Actions (Has_No_Init => True); end if; @@ -2517,25 +2526,69 @@ package body Exp_Ch7 is end; end if; - -- Return objects use a flag to aid their potential finalization - -- then the enclosing function fails to return properly. Generate: - -- - -- if not Flag then - -- - -- end if; - if Ekind_In (Obj_Id, E_Constant, E_Variable) - and then Is_Return_Object (Obj_Id) - and then Present (Return_Flag (Obj_Id)) + and then Present (Return_Flag_Or_Transient_Decl (Obj_Id)) then - Fin_Stmts := New_List ( - Make_If_Statement (Loc, - Condition => - Make_Op_Not (Loc, - Right_Opnd => - New_Reference_To (Return_Flag (Obj_Id), Loc)), + -- Return objects use a flag to aid their potential + -- finalization when the enclosing function fails to return + -- properly. Generate: + -- + -- if not Flag then + -- + -- end if; + + if Is_Return_Object (Obj_Id) then + Fin_Stmts := New_List ( + Make_If_Statement (Loc, + Condition => + Make_Op_Not (Loc, + Right_Opnd => + New_Reference_To + (Return_Flag_Or_Transient_Decl (Obj_Id), Loc)), + + Then_Statements => Fin_Stmts)); + + -- Temporaries created for the purpose of "exporting" a + -- controlled transient out of an Expression_With_Actions (EWA) + -- need guards. The following illustrates the usage of such + -- temporaries. + + -- Access_Typ : access [all] Obj_Typ; + -- Temp : Access_Typ := null; + -- := ...; + + -- do + -- Ctrl_Trans : [access [all]] Obj_Typ := ...; + -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer + -- + -- Temp := Ctrl_Trans'Unchecked_Access; + -- in ... end; + + -- The finalization machinery does not process EWA nodes as + -- this may lead to premature finalization of expressions. Note + -- that Temp is marked as being properly initialized regardless + -- of whether the initialization of Ctrl_Trans succeeded. Since + -- a failed initialization may leave Temp with a value of null, + -- add a guard to handle this case: + + -- if Obj /= null then + -- + -- end if; - Then_Statements => Fin_Stmts)); + else + pragma Assert + (Nkind (Return_Flag_Or_Transient_Decl (Obj_Id)) = + N_Object_Declaration); + + Fin_Stmts := New_List ( + Make_If_Statement (Loc, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => New_Reference_To (Obj_Id, Loc), + Right_Opnd => Make_Null (Loc)), + + Then_Statements => Fin_Stmts)); + end if; end if; end if; diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 60711df9c48..e3304a41d16 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -6189,6 +6189,7 @@ package body Exp_Disp is if not No_Run_Time_Mode and then Ada_Version >= Ada_2005 and then RTE_Available (RE_Check_TSD) + and then not Debug_Flag_QQ then Append_To (Elab_Code, Make_Procedure_Call_Statement (Loc, diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 72831936483..2fd4e446244 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -2696,6 +2696,15 @@ package body Exp_Util is then return True; + elsif Is_Access_Type (Obj_Typ) + and then Present (Return_Flag_Or_Transient_Decl (Obj_Id)) + and then Nkind (Return_Flag_Or_Transient_Decl (Obj_Id)) = + N_Object_Declaration + and then Is_Finalizable_Transient + (Return_Flag_Or_Transient_Decl (Obj_Id), Decl) + then + return True; + -- Simple protected objects which use type System.Tasking. -- Protected_Objects.Protection to manage their locks should be -- treated as controlled since they require manual cleanup. @@ -2732,7 +2741,7 @@ package body Exp_Util is elsif Needs_Finalization (Obj_Typ) and then Is_Return_Object (Obj_Id) - and then Present (Return_Flag (Obj_Id)) + and then Present (Return_Flag_Or_Transient_Decl (Obj_Id)) then return True; end if; diff --git a/gcc/ada/expander.adb b/gcc/ada/expander.adb index ffb8dad1162..95b5d978c67 100644 --- a/gcc/ada/expander.adb +++ b/gcc/ada/expander.adb @@ -205,6 +205,9 @@ package body Expander is when N_Explicit_Dereference => Expand_N_Explicit_Dereference (N); + when N_Expression_With_Actions => + Expand_N_Expression_With_Actions (N); + when N_Extended_Return_Statement => Expand_N_Extended_Return_Statement (N); diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb index 811e0e02a2e..98d66d3b19d 100644 --- a/gcc/ada/par_sco.adb +++ b/gcc/ada/par_sco.adb @@ -466,10 +466,12 @@ package body Par_SCO is Loc := Sloc (Parent (Parent (N))); - -- Record sloc of pragma (pragmas don't nest) + if T = 'P' then + -- Record sloc of pragma (pragmas don't nest) - pragma Assert (Pragma_Sloc = No_Location); - Pragma_Sloc := Loc; + pragma Assert (Pragma_Sloc = No_Location); + Pragma_Sloc := Loc; + end if; when 'X' => diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index ba3b683ec04..2f531c946e4 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -6699,7 +6699,7 @@ package body Prj.Nmsc is if Current_Verbosity = High then Debug_Increase_Indent ("Checking file (rank=" & Source_Dir_Rank'Img & ")", - Name_Id (Path)); + Name_Id (Display_Path)); end if; if Name_Loc = No_Name_Location then diff --git a/gcc/ada/projects.texi b/gcc/ada/projects.texi index cd0970a3aaf..1ca76d2d62d 100644 --- a/gcc/ada/projects.texi +++ b/gcc/ada/projects.texi @@ -1626,7 +1626,7 @@ Other library-related attributes can be used to change the defaults: @item @b{Library_Options}: @cindex @code{Library_Options} - This attribute may be used to specified additional switches (last switches) + This attribute may be used to specify additional switches (last switches) when linking a shared library. @item @b{Leading_Library_Options}: diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index e2e566dda68..2288ac0a9f0 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -755,8 +755,9 @@ package body Sem_Ch10 is -- If the unit is a subprogram body, then we similarly need to analyze -- its spec. However, things are a little simpler in this case, because - -- here, this analysis is done only for error checking and consistency - -- purposes, so there's nothing else to be done. + -- here, this analysis is done mostly for error checking and consistency + -- purposes (but not only, e.g. there could be a contract on the spec), + -- so there's nothing else to be done. elsif Nkind (Unit_Node) = N_Subprogram_Body then if Acts_As_Spec (N) then diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 3c93ca3f84b..b264d8bfd61 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -12446,26 +12446,6 @@ package body Sem_Ch12 is -- All other cases than aggregates else - -- For pragmas, we propagate the Enabled status for the - -- relevant pragmas to the original generic tree. This was - -- originally needed for SCO generation. It is no longer - -- needed there (since we use the Sloc value in calls to - -- Set_SCO_Pragma_Enabled), but it seems a generally good - -- idea to have this flag set properly. - - if Nkind (N) = N_Pragma - and then - (Pragma_Name (N) = Name_Assert or else - Pragma_Name (N) = Name_Check or else - Pragma_Name (N) = Name_Precondition or else - Pragma_Name (N) = Name_Postcondition) - and then Present (Associated_Node (Pragma_Identifier (N))) - then - Set_Pragma_Enabled (N, - Pragma_Enabled - (Parent (Associated_Node (Pragma_Identifier (N))))); - end if; - Save_Global_Descendant (Field1 (N)); Save_Global_Descendant (Field2 (N)); Save_Global_Descendant (Field3 (N)); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 1dd2f58ea64..53608c66c71 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -1719,7 +1719,6 @@ package body Sem_Prag is -- Record if pragma is enabled if Check_Enabled (Pname) then - Set_Pragma_Enabled (N); Set_SCO_Pragma_Enabled (Loc); end if; @@ -6695,8 +6694,6 @@ package body Sem_Prag is Check_On := Check_Enabled (Chars (Get_Pragma_Arg (Arg1))); if Check_On then - Set_Pragma_Enabled (N); - Set_Pragma_Enabled (Original_Node (N)); Set_SCO_Pragma_Enabled (Loc); end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 2a90f677811..5d22fb1b095 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -12478,8 +12478,12 @@ package body Sem_Util is ---------------- procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is - Found_Type : constant Entity_Id := First_Subtype (Etype (Expr)); - Expec_Type : constant Entity_Id := First_Subtype (Expected_Type); + Found_Type : constant Entity_Id := First_Subtype (Etype (Expr)); + Expec_Type : constant Entity_Id := First_Subtype (Expected_Type); + + Matching_Field : Entity_Id; + -- Entity to give a more precise suggestion on how to write a one- + -- element positional aggregate. function Has_One_Matching_Field return Boolean; -- Determines if Expec_Type is a record type with a single component or @@ -12494,11 +12498,27 @@ package body Sem_Util is E : Entity_Id; begin + Matching_Field := Empty; + if Is_Array_Type (Expec_Type) and then Number_Dimensions (Expec_Type) = 1 and then Covers (Etype (Component_Type (Expec_Type)), Found_Type) then + -- Use type name if available. This excludes multidimensional + -- arrays and anonymous arrays. + + if Comes_From_Source (Expec_Type) then + Matching_Field := Expec_Type; + + -- For an assignment, use name of target. + + elsif Nkind (Parent (Expr)) = N_Assignment_Statement + and then Is_Entity_Name (Name (Parent (Expr))) + then + Matching_Field := Entity (Name (Parent (Expr))); + end if; + return True; elsif not Is_Record_Type (Expec_Type) then @@ -12529,6 +12549,7 @@ package body Sem_Util is return False; else + Matching_Field := E; return True; end if; end if; @@ -12577,6 +12598,16 @@ package body Sem_Util is and then Has_One_Matching_Field then Error_Msg_N ("positional aggregate cannot have one component", Expr); + if Present (Matching_Field) then + if Is_Array_Type (Expec_Type) then + Error_Msg_NE + ("\write instead `&''First ='> ...`", Expr, Matching_Field); + + else + Error_Msg_NE + ("\write instead `& ='> ...`", Expr, Matching_Field); + end if; + end if; -- Another special check, if we are looking for a pool-specific access -- type and we found an E_Access_Attribute_Type, then we have the case diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index b225b6b82fb..f2a11ba8923 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -2406,14 +2406,6 @@ package body Sinfo is return List2 (N); end Pragma_Argument_Associations; - function Pragma_Enabled - (N : Node_Id) return Boolean is - begin - pragma Assert (False - or else NT (N).Nkind = N_Pragma); - return Flag5 (N); - end Pragma_Enabled; - function Pragma_Identifier (N : Node_Id) return Node_Id is begin @@ -5440,14 +5432,6 @@ package body Sinfo is Set_List2_With_Parent (N, Val); end Set_Pragma_Argument_Associations; - procedure Set_Pragma_Enabled - (N : Node_Id; Val : Boolean := True) is - begin - pragma Assert (False - or else NT (N).Nkind = N_Pragma); - Set_Flag5 (N, Val); - end Set_Pragma_Enabled; - procedure Set_Pragma_Identifier (N : Node_Id; Val : Node_Id) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index ad81c77f841..d859b750888 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1587,12 +1587,6 @@ package Sinfo is -- package specification. This field is Empty for library bodies (the -- parent spec in this case can be found from the corresponding spec). - -- Pragma_Enabled (Flag5-Sem) - -- Present in N_Pragma nodes. This flag is relevant only for pragmas - -- Assert, Check, Precondition, and Postcondition. It is true if the - -- check corresponding to the pragma type is enabled at the point where - -- the pragma appears. - -- Present_Expr (Uint3-Sem) -- Present in an N_Variant node. This has a meaningful value only after -- Gigi has back annotated the tree with representation information. At @@ -2062,7 +2056,6 @@ package Sinfo is -- Pragma_Argument_Associations (List2) (set to No_List if none) -- Pragma_Identifier (Node4) -- Next_Rep_Item (Node5-Sem) - -- Pragma_Enabled (Flag5-Sem) -- From_Aspect_Specification (Flag13-Sem) -- Is_Delayed_Aspect (Flag14-Sem) -- Import_Interface_Present (Flag16-Sem) @@ -8734,9 +8727,6 @@ package Sinfo is function Pragma_Argument_Associations (N : Node_Id) return List_Id; -- List2 - function Pragma_Enabled - (N : Node_Id) return Boolean; -- Flag5 - function Pragma_Identifier (N : Node_Id) return Node_Id; -- Node4 @@ -9700,9 +9690,6 @@ package Sinfo is procedure Set_Pragma_Argument_Associations (N : Node_Id; Val : List_Id); -- List2 - procedure Set_Pragma_Enabled - (N : Node_Id; Val : Boolean := True); -- Flag5 - procedure Set_Pragma_Identifier (N : Node_Id; Val : Node_Id); -- Node4 @@ -11897,7 +11884,6 @@ package Sinfo is pragma Inline (Parent_Spec); pragma Inline (Position); pragma Inline (Pragma_Argument_Associations); - pragma Inline (Pragma_Enabled); pragma Inline (Pragma_Identifier); pragma Inline (Pragmas_After); pragma Inline (Pragmas_Before); @@ -12216,7 +12202,6 @@ package Sinfo is pragma Inline (Set_Parent_Spec); pragma Inline (Set_Position); pragma Inline (Set_Pragma_Argument_Associations); - pragma Inline (Set_Pragma_Enabled); pragma Inline (Set_Pragma_Identifier); pragma Inline (Set_Pragmas_After); pragma Inline (Set_Pragmas_Before);