From 60370fb12798f314c3fd4f8cbb557a4cc9a164c1 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 29 Aug 2011 15:01:34 +0200 Subject: [PATCH] [multiple changes] 2011-08-29 Hristian Kirtchev * s-finmas.adb (Finalize): Check Finalize_Address of the master rather than the current node. * s-finmas.ads: Move field Finalize_Address from type FM_Node to Finalization_Master. The list headers have two fields instead of three. This should fix alignment issue but subpool allocations are now unusable. Alphabetize subprograms. * s-stposu.adb (Allocate_Any_Controlled): Use the offset rather than the size of the header when converting the beginning of the object to a FM_Node. Set the master's Finalize_Address attribute if not already set. (Deallocate_Any_Controlled): Use the offset rather than the size of the header when converting the beginning of the object to a FM_Node. 2011-08-29 Gary Dismukes * exp_ch11.adb (Expand_N_Raise_Statement): Don't suppress expansion of reraise when compiling for CodePeer. 2011-08-29 Arnaud Charlet * a-iteint.ads, Makefile.rtl: Add missing compilation of a-iteint.ads, now needed by a-convec.adb. Fix warning. 2011-08-29 Hristian Kirtchev * exp_util.adb (Build_Allocate_Deallocate_Proc): Add a guard for the processing of TSS routine Finalize_Address when compiling in CodePeer_Mode. 2011-08-29 Thomas Quinot * a-strunb.ads, einfo.ads, g-comlin.ads, sem_ch6.adb, sem_warn.adb: Minor reformatting. 2011-08-29 Emmanuel Briot * prj-conf.adb (Get_Config_Switches): Also collect the list of languages from aggregated projects. 2011-08-29 Yannick Moy * lib-xref-alfa.adb, lib-xref.ads (Traverse_Declarations_Or_Statements, Traverse_Handled_Statement_Sequence, Traverse_Package_Body, Traverse_Package_Declaration, Traverse_Subprogram_Body, Traverse_Compilation_Unit): Add a parameter Inside_Stubs so that bodies for stubs are traversed too when parameter is set (Traverse_All_Compilation_Units): Traverse without going inside stubs (Traverse_Declarations_Or_Statements): Do the special traversing for stubs when required. * sem_util.adb, sem_util.ads (Get_Body_From_Stub): New function to return subprogram or package body from stub. (Is_Subprogram_Stub_Without_Prior_Declaration): New function to detect stubs without prior subprogram decl. 2011-08-29 Vasiliy Fofanov * gnat_ugn.texi: Fix typo. From-SVN: r178219 --- gcc/ada/ChangeLog | 60 +++++++++++++++++++++ gcc/ada/Makefile.rtl | 1 + gcc/ada/a-iteint.ads | 1 + gcc/ada/a-strunb.ads | 4 +- gcc/ada/einfo.ads | 22 ++++---- gcc/ada/exp_ch11.adb | 4 +- gcc/ada/exp_util.adb | 8 ++- gcc/ada/g-comlin.ads | 3 +- gcc/ada/gnat_ugn.texi | 2 +- gcc/ada/lib-xref-alfa.adb | 133 ++++++++++++++++++++++++++++++---------------- gcc/ada/lib-xref.ads | 5 +- gcc/ada/prj-conf.adb | 70 +++++++++++++++--------- gcc/ada/s-finmas.adb | 36 ++++++------- gcc/ada/s-finmas.ads | 14 ++--- gcc/ada/s-stposu.adb | 10 ++-- gcc/ada/sem_ch6.adb | 2 +- gcc/ada/sem_util.adb | 25 +++++++++ gcc/ada/sem_util.ads | 8 +++ gcc/ada/sem_warn.adb | 4 +- 19 files changed, 287 insertions(+), 125 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5ff1db5..3d4853f 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,65 @@ 2011-08-29 Hristian Kirtchev + * s-finmas.adb (Finalize): Check Finalize_Address of the master rather + than the current node. + * s-finmas.ads: Move field Finalize_Address from type FM_Node to + Finalization_Master. The list headers have two fields instead of three. + This should fix alignment issue but subpool allocations are now + unusable. Alphabetize subprograms. + * s-stposu.adb (Allocate_Any_Controlled): Use the offset rather than + the size of the header when converting the beginning of the object to + a FM_Node. Set the master's Finalize_Address attribute if not already + set. + (Deallocate_Any_Controlled): Use the offset rather than the size of the + header when converting the beginning of the object to a FM_Node. + +2011-08-29 Gary Dismukes + + * exp_ch11.adb (Expand_N_Raise_Statement): Don't suppress expansion of + reraise when compiling for CodePeer. + +2011-08-29 Arnaud Charlet + + * a-iteint.ads, Makefile.rtl: Add missing compilation of a-iteint.ads, + now needed by a-convec.adb. Fix warning. + +2011-08-29 Hristian Kirtchev + + * exp_util.adb (Build_Allocate_Deallocate_Proc): Add a guard for the + processing of TSS routine Finalize_Address when compiling in + CodePeer_Mode. + +2011-08-29 Thomas Quinot + + * a-strunb.ads, einfo.ads, g-comlin.ads, sem_ch6.adb, + sem_warn.adb: Minor reformatting. + +2011-08-29 Emmanuel Briot + + * prj-conf.adb (Get_Config_Switches): Also collect the list of + languages from aggregated projects. + +2011-08-29 Yannick Moy + + * lib-xref-alfa.adb, lib-xref.ads (Traverse_Declarations_Or_Statements, + Traverse_Handled_Statement_Sequence, Traverse_Package_Body, + Traverse_Package_Declaration, Traverse_Subprogram_Body, + Traverse_Compilation_Unit): Add a parameter Inside_Stubs so that bodies + for stubs are traversed too when parameter is set + (Traverse_All_Compilation_Units): Traverse without going inside stubs + (Traverse_Declarations_Or_Statements): Do the special traversing for + stubs when required. + * sem_util.adb, sem_util.ads (Get_Body_From_Stub): New function to + return subprogram or package body from stub. + (Is_Subprogram_Stub_Without_Prior_Declaration): New function to detect + stubs without prior subprogram decl. + +2011-08-29 Vasiliy Fofanov + + * gnat_ugn.texi: Fix typo. + +2011-08-29 Hristian Kirtchev + * s-stposu.adb (Allocate_Any_Controlled): Reimplement the mechanism which accounts for size vs alignment issues and calculates the size of the list header. diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 683c15aa..3115cb7 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -161,6 +161,7 @@ GNATRTL_NONTASKING_OBJS= \ a-fzteio$(objext) \ a-inteio$(objext) \ a-ioexce$(objext) \ + a-iteint$(objext) \ a-iwteio$(objext) \ a-izteio$(objext) \ a-lcteio$(objext) \ diff --git a/gcc/ada/a-iteint.ads b/gcc/ada/a-iteint.ads index c6aaa76..192bdcb 100644 --- a/gcc/ada/a-iteint.ads +++ b/gcc/ada/a-iteint.ads @@ -33,6 +33,7 @@ generic type Cursor; with function Has_Element (Position : Cursor) return Boolean; + pragma Unreferenced (Has_Element); package Ada.Iterator_Interfaces is pragma Pure; diff --git a/gcc/ada/a-strunb.ads b/gcc/ada/a-strunb.ads index af063f0..3341466 100644 --- a/gcc/ada/a-strunb.ads +++ b/gcc/ada/a-strunb.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. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -433,5 +433,5 @@ private Null_Unbounded_String : constant Unbounded_String := (AF.Controlled with Reference => Null_String'Access, - Last => 0); + Last => 0); end Ada.Strings.Unbounded; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 6f061d1..c60fdd1 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1237,10 +1237,10 @@ package Einfo is -- representation pragmas nodes and representation clause nodes that -- apply to the entity, linked using Next_Rep_Item, with Empty marking -- the end of the list. In the case of derived types and subtypes, the --- new entity inherits the chain at the point of declaration. This --- means that it is possible to have multiple instances of the same --- kind of rep item on the chain, in which case it is the first one --- that applies to the entity. +-- new entity inherits the chain at the point of declaration. This means +-- that it is possible to have multiple instances of the same kind of rep +-- item on the chain, in which case it is the first one that applies to +-- the entity. -- -- Note: pragmas that can apply to more than one overloadable entity, -- (Convention, Interface, Inline, Inline_Always, Import, Export, @@ -1260,8 +1260,8 @@ package Einfo is -- Linker_Section pragma -- Weak_External pragma -- --- If any of these items are present, then the flag Has_Gigi_Rep_Item --- is set, indicating that Gigi should search the chain. +-- If any of these items are present, then the flag Has_Gigi_Rep_Item is +-- set, indicating that Gigi should search the chain. -- -- Other representation items are included in the chain so that error -- messages can easily locate the relevant nodes for posting errors. @@ -1274,10 +1274,10 @@ package Einfo is -- the floating-point representation to be used. -- Freeze_Node (Node7) --- Present in all entities. If there is an associated freeze node for --- the entity, this field references this freeze node. If no freeze --- node is associated with the entity, then this field is Empty. See --- package Freeze for further details. +-- Present in all entities. If there is an associated freeze node for the +-- entity, this field references this freeze node. If no freeze node is +-- associated with the entity, then this field is Empty. See package +-- Freeze for further details. -- From_With_Type (Flag159) -- Present in package and type entities. Indicates that the entity @@ -3265,7 +3265,7 @@ package Einfo is -- Package_Instantiation (Node26) -- Present in packages and generic packages. When present, this field --- references an N_Package_Instantiation node associated with an +-- references an N_Generic_Instantiation node associated with an -- instantiated package. In the case where the referenced node has -- been rewritten to an N_Package_Specification, the instantiation -- node is available from the Original_Node field of the package spec diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index 2f16743..ceca349 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -1666,9 +1666,11 @@ package body Exp_Ch11 is else - -- Don't expand if back end exception handling active + -- Bypass expansion to a run-time call when back-end exception + -- handling is active, unless the target is a VM or CodePeer. if VM_Target = No_VM + and then not CodePeer_Mode and then Exception_Mechanism = Back_End_Exceptions then return; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 0d1f73c..d712570 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -628,9 +628,13 @@ package body Exp_Util is -- d) Finalize_Address - Fin_Addr_Id := Find_Finalize_Address (Desig_Typ); + -- Primitive Finalize_Address is never generated in CodePeer mode + -- since it contains an Unchecked_Conversion. - if Needs_Finalization (Desig_Typ) then + if Needs_Finalization (Desig_Typ) + and then not CodePeer_Mode + then + Fin_Addr_Id := Find_Finalize_Address (Desig_Typ); pragma Assert (Present (Fin_Addr_Id)); Append_To (Actuals, diff --git a/gcc/ada/g-comlin.ads b/gcc/ada/g-comlin.ads index 0c4c96e..ec84280 100644 --- a/gcc/ada/g-comlin.ads +++ b/gcc/ada/g-comlin.ads @@ -492,11 +492,12 @@ package GNAT.Command_Line is Invalid_Parameter : exception; -- Raised when a parameter is missing, or an attempt is made to obtain a - -- parameter for a switch that does not allow a parameter + -- parameter for a switch that does not allow a parameter. ----------------------------------------- -- Expansion of command line arguments -- ----------------------------------------- + -- These subprograms take care of of expanding globbing patterns on the -- command line. On Unix, such expansion is done by the shell before your -- application is called. But on Windows you must do this expansion diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 64a4489..def9349 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -21373,7 +21373,7 @@ information about several specific platforms. @item @code{@ @ @ @ }Tasking @tab native Win32 threads @item @code{@ @ @ @ }Exceptions @tab ZCX @* -@item @code{@ @ }@i{rts-sjlj (default)} +@item @code{@ @ }@i{rts-sjlj} @item @code{@ @ @ @ }Tasking @tab native Win32 threads @item @code{@ @ @ @ }Exceptions @tab SJLJ @* diff --git a/gcc/ada/lib-xref-alfa.adb b/gcc/ada/lib-xref-alfa.adb index 58c4ecc..75dea7f 100644 --- a/gcc/ada/lib-xref-alfa.adb +++ b/gcc/ada/lib-xref-alfa.adb @@ -165,20 +165,25 @@ package body ALFA is -- Hash function for hash table procedure Traverse_Declarations_Or_Statements - (L : List_Id; - Process : Node_Processing); + (L : List_Id; + Process : Node_Processing; + Inside_Stubs : Boolean); procedure Traverse_Handled_Statement_Sequence - (N : Node_Id; - Process : Node_Processing); + (N : Node_Id; + Process : Node_Processing; + Inside_Stubs : Boolean); procedure Traverse_Package_Body - (N : Node_Id; - Process : Node_Processing); + (N : Node_Id; + Process : Node_Processing; + Inside_Stubs : Boolean); procedure Traverse_Package_Declaration - (N : Node_Id; - Process : Node_Processing); + (N : Node_Id; + Process : Node_Processing; + Inside_Stubs : Boolean); procedure Traverse_Subprogram_Body - (N : Node_Id; - Process : Node_Processing); + (N : Node_Id; + Process : Node_Processing; + Inside_Stubs : Boolean); -- Traverse the corresponding constructs, calling Process on all -- declarations. @@ -201,7 +206,8 @@ package body ALFA is From := ALFA_Scope_Table.Last + 1; - Traverse_Compilation_Unit (Cunit (U), Detect_And_Add_ALFA_Scope'Access); + Traverse_Compilation_Unit (Cunit (U), Detect_And_Add_ALFA_Scope'Access, + Inside_Stubs => False); -- Update scope numbers @@ -904,7 +910,7 @@ package body ALFA is procedure Traverse_All_Compilation_Units (Process : Node_Processing) is begin for U in Units.First .. Last_Unit loop - Traverse_Compilation_Unit (Cunit (U), Process); + Traverse_Compilation_Unit (Cunit (U), Process, Inside_Stubs => False); end loop; end Traverse_All_Compilation_Units; @@ -913,8 +919,9 @@ package body ALFA is ------------------------------- procedure Traverse_Compilation_Unit - (CU : Node_Id; - Process : Node_Processing) + (CU : Node_Id; + Process : Node_Processing; + Inside_Stubs : Boolean) is Lu : Node_Id; @@ -938,16 +945,16 @@ package body ALFA is -- Traverse the unit if Nkind (Lu) = N_Subprogram_Body then - Traverse_Subprogram_Body (Lu, Process); + Traverse_Subprogram_Body (Lu, Process, Inside_Stubs); elsif Nkind (Lu) = N_Subprogram_Declaration then null; elsif Nkind (Lu) = N_Package_Declaration then - Traverse_Package_Declaration (Lu, Process); + Traverse_Package_Declaration (Lu, Process, Inside_Stubs); elsif Nkind (Lu) = N_Package_Body then - Traverse_Package_Body (Lu, Process); + Traverse_Package_Body (Lu, Process, Inside_Stubs); -- ??? TBD @@ -972,8 +979,9 @@ package body ALFA is ----------------------------------------- procedure Traverse_Declarations_Or_Statements - (L : List_Id; - Process : Node_Processing) + (L : List_Id; + Process : Node_Processing; + Inside_Stubs : Boolean) is N : Node_Id; @@ -996,7 +1004,7 @@ package body ALFA is -- Package declaration when N_Package_Declaration => - Traverse_Package_Declaration (N, Process); + Traverse_Package_Declaration (N, Process, Inside_Stubs); -- Generic package declaration ??? TBD @@ -1007,9 +1015,21 @@ package body ALFA is when N_Package_Body => if Ekind (Defining_Entity (N)) /= E_Generic_Package then - Traverse_Package_Body (N, Process); + Traverse_Package_Body (N, Process, Inside_Stubs); end if; + when N_Package_Body_Stub => + declare + Body_N : constant Node_Id := Get_Body_From_Stub (N); + begin + if Inside_Stubs + and then + Ekind (Defining_Entity (Body_N)) /= E_Generic_Package + then + Traverse_Package_Body (Body_N, Process, Inside_Stubs); + end if; + end; + -- Subprogram declaration when N_Subprogram_Declaration => @@ -1024,22 +1044,35 @@ package body ALFA is when N_Subprogram_Body => if not Is_Generic_Subprogram (Defining_Entity (N)) then - Traverse_Subprogram_Body (N, Process); + Traverse_Subprogram_Body (N, Process, Inside_Stubs); end if; + when N_Subprogram_Body_Stub => + declare + Body_N : constant Node_Id := Get_Body_From_Stub (N); + begin + if Inside_Stubs + and then + not Is_Generic_Subprogram (Defining_Entity (Body_N)) + then + Traverse_Subprogram_Body (Body_N, Process, Inside_Stubs); + end if; + end; + -- Block statement when N_Block_Statement => - Traverse_Declarations_Or_Statements (Declarations (N), Process); + Traverse_Declarations_Or_Statements + (Declarations (N), Process, Inside_Stubs); Traverse_Handled_Statement_Sequence - (Handled_Statement_Sequence (N), Process); + (Handled_Statement_Sequence (N), Process, Inside_Stubs); when N_If_Statement => -- Traverse the statements in the THEN part Traverse_Declarations_Or_Statements - (Then_Statements (N), Process); + (Then_Statements (N), Process, Inside_Stubs); -- Loop through ELSIF parts if present @@ -1050,7 +1083,7 @@ package body ALFA is begin while Present (Elif) loop Traverse_Declarations_Or_Statements - (Then_Statements (Elif), Process); + (Then_Statements (Elif), Process, Inside_Stubs); Next (Elif); end loop; end; @@ -1059,7 +1092,7 @@ package body ALFA is -- Finally traverse the ELSE statements if present Traverse_Declarations_Or_Statements - (Else_Statements (N), Process); + (Else_Statements (N), Process, Inside_Stubs); -- Case statement @@ -1073,7 +1106,7 @@ package body ALFA is Alt := First (Alternatives (N)); while Present (Alt) loop Traverse_Declarations_Or_Statements - (Statements (Alt), Process); + (Statements (Alt), Process, Inside_Stubs); Next (Alt); end loop; end; @@ -1082,12 +1115,13 @@ package body ALFA is when N_Extended_Return_Statement => Traverse_Handled_Statement_Sequence - (Handled_Statement_Sequence (N), Process); + (Handled_Statement_Sequence (N), Process, Inside_Stubs); -- Loop when N_Loop_Statement => - Traverse_Declarations_Or_Statements (Statements (N), Process); + Traverse_Declarations_Or_Statements + (Statements (N), Process, Inside_Stubs); when others => null; @@ -1102,20 +1136,22 @@ package body ALFA is ----------------------------------------- procedure Traverse_Handled_Statement_Sequence - (N : Node_Id; - Process : Node_Processing) + (N : Node_Id; + Process : Node_Processing; + Inside_Stubs : Boolean) is Handler : Node_Id; begin if Present (N) then - Traverse_Declarations_Or_Statements (Statements (N), Process); + Traverse_Declarations_Or_Statements + (Statements (N), Process, Inside_Stubs); if Present (Exception_Handlers (N)) then Handler := First (Exception_Handlers (N)); while Present (Handler) loop Traverse_Declarations_Or_Statements - (Statements (Handler), Process); + (Statements (Handler), Process, Inside_Stubs); Next (Handler); end loop; end if; @@ -1127,12 +1163,14 @@ package body ALFA is --------------------------- procedure Traverse_Package_Body - (N : Node_Id; - Process : Node_Processing) is + (N : Node_Id; + Process : Node_Processing; + Inside_Stubs : Boolean) is begin - Traverse_Declarations_Or_Statements (Declarations (N), Process); + Traverse_Declarations_Or_Statements + (Declarations (N), Process, Inside_Stubs); Traverse_Handled_Statement_Sequence - (Handled_Statement_Sequence (N), Process); + (Handled_Statement_Sequence (N), Process, Inside_Stubs); end Traverse_Package_Body; ---------------------------------- @@ -1140,15 +1178,16 @@ package body ALFA is ---------------------------------- procedure Traverse_Package_Declaration - (N : Node_Id; - Process : Node_Processing) + (N : Node_Id; + Process : Node_Processing; + Inside_Stubs : Boolean) is Spec : constant Node_Id := Specification (N); begin Traverse_Declarations_Or_Statements - (Visible_Declarations (Spec), Process); + (Visible_Declarations (Spec), Process, Inside_Stubs); Traverse_Declarations_Or_Statements - (Private_Declarations (Spec), Process); + (Private_Declarations (Spec), Process, Inside_Stubs); end Traverse_Package_Declaration; ------------------------------ @@ -1156,12 +1195,14 @@ package body ALFA is ------------------------------ procedure Traverse_Subprogram_Body - (N : Node_Id; - Process : Node_Processing) is + (N : Node_Id; + Process : Node_Processing; + Inside_Stubs : Boolean) is begin - Traverse_Declarations_Or_Statements (Declarations (N), Process); + Traverse_Declarations_Or_Statements + (Declarations (N), Process, Inside_Stubs); Traverse_Handled_Statement_Sequence - (Handled_Statement_Sequence (N), Process); + (Handled_Statement_Sequence (N), Process, Inside_Stubs); end Traverse_Subprogram_Body; end ALFA; diff --git a/gcc/ada/lib-xref.ads b/gcc/ada/lib-xref.ads index ecee22a..60c4b35 100644 --- a/gcc/ada/lib-xref.ads +++ b/gcc/ada/lib-xref.ads @@ -593,8 +593,9 @@ package Lib.Xref is type Node_Processing is access procedure (N : Node_Id); procedure Traverse_Compilation_Unit - (CU : Node_Id; - Process : Node_Processing); + (CU : Node_Id; + Process : Node_Processing; + Inside_Stubs : Boolean); procedure Traverse_All_Compilation_Units (Process : Node_Processing); -- Call Process on all declarations through all compilation units diff --git a/gcc/ada/prj-conf.adb b/gcc/ada/prj-conf.adb index a1d9fe9..c6e37ee 100644 --- a/gcc/ada/prj-conf.adb +++ b/gcc/ada/prj-conf.adb @@ -722,28 +722,32 @@ package body Prj.Conf is -- Hash table to keep the languages used in the project tree IDE : constant Package_Id := - Value_Of (Name_Ide, Project.Decl.Packages, Shared); - - Prj_Iter : Project_List; - List : String_List_Id; - Elem : String_Element; - Lang : Name_Id; - Variable : Variable_Value; - Name : Name_Id; - Count : Natural; - Result : Argument_List_Access; - - Check_Default : Boolean; - - begin - Prj_Iter := Project_Tree.Projects; - while Prj_Iter /= null loop - if Might_Have_Sources (Prj_Iter.Project) then + Value_Of (Name_Ide, Project.Decl.Packages, Shared); + + procedure Add_Config_Switches_For_Project + (Project : Project_Id; + Tree : Project_Tree_Ref; + With_State : in out Integer); + -- Add all --config switches for this project. This is also called + -- for aggregate projects. + + procedure Add_Config_Switches_For_Project + (Project : Project_Id; + Tree : Project_Tree_Ref; + With_State : in out Integer) + is + pragma Unreferenced (With_State); + Shared : constant Shared_Project_Tree_Data_Access := Tree.Shared; + + Variable : Variable_Value; + Check_Default : Boolean; + Lang : Name_Id; + List : String_List_Id; + Elem : String_Element; + begin + if Might_Have_Sources (Project) then Variable := - Value_Of - (Name_Languages, - Prj_Iter.Project.Decl.Attributes, - Shared); + Value_Of (Name_Languages, Project.Decl.Attributes, Shared); if Variable = Nil_Variable_Value or else Variable.Default @@ -752,13 +756,13 @@ package body Prj.Conf is -- project, or if it extends a project with no Languages, -- check for Default_Language. - Check_Default := Prj_Iter.Project.Extends = No_Project; + Check_Default := Project.Extends = No_Project; if not Check_Default then Variable := Value_Of (Name_Languages, - Prj_Iter.Project.Extends.Decl.Attributes, + Project.Extends.Decl.Attributes, Shared); Check_Default := Variable /= Nil_Variable_Value @@ -769,7 +773,7 @@ package body Prj.Conf is Variable := Value_Of (Name_Default_Language, - Prj_Iter.Project.Decl.Attributes, + Project.Decl.Attributes, Shared); if Variable /= Nil_Variable_Value @@ -805,9 +809,23 @@ package body Prj.Conf is end loop; end if; end if; + end Add_Config_Switches_For_Project; - Prj_Iter := Prj_Iter.Next; - end loop; + procedure For_Every_Imported_Project is new For_Every_Project_Imported + (State => Integer, Action => Add_Config_Switches_For_Project); + + Name : Name_Id; + Count : Natural; + Result : Argument_List_Access; + Variable : Variable_Value; + Dummy : Integer := 0; + + begin + For_Every_Imported_Project + (By => Project, + Tree => Project_Tree, + With_State => Dummy, + Include_Aggregated => True); Name := Language_Htable.Get_First; Count := 0; diff --git a/gcc/ada/s-finmas.adb b/gcc/ada/s-finmas.adb index 7a5be2c..71dbeb8 100644 --- a/gcc/ada/s-finmas.adb +++ b/gcc/ada/s-finmas.adb @@ -128,27 +128,23 @@ package body System.Finalization_Masters is Curr_Ptr := Master.Objects.Next; while Curr_Ptr /= Master.Objects'Unchecked_Access loop + + -- If primitive Finalize_Address is not set, then the expansion of + -- the designated type or that of the allocator failed. This is a + -- serious error. + + if Master.Finalize_Address = null then + raise Program_Error + with "primitive Finalize_Address not available"; + end if; + + -- Skip the list header in order to offer proper object layout for + -- finalization and call Finalize_Address. + + Obj_Addr := Curr_Ptr.all'Address + Header_Offset; + begin - -- If primitive Finalize_Address is not set, then the expansion of - -- the designated type or that of the allocator failed. This is a - -- serious error. - - -- Note: The Program_Error must be raised from the same block as - -- the finalization call. If Finalize_Address is not present for - -- a particular object, this should not stop the finalization of - -- the remaining objects. - - if Curr_Ptr.Finalize_Address = null then - raise Program_Error - with "primitive Finalize_Address not available"; - - -- Skip the list header in order to offer proper object layout for - -- finalization and call Finalize_Address. - - else - Obj_Addr := Curr_Ptr.all'Address + Header_Offset; - Curr_Ptr.Finalize_Address (Obj_Addr); - end if; + Master.Finalize_Address (Obj_Addr); exception when Fin_Occur : others => diff --git a/gcc/ada/s-finmas.ads b/gcc/ada/s-finmas.ads index cd2b74c..3932021 100644 --- a/gcc/ada/s-finmas.ads +++ b/gcc/ada/s-finmas.ads @@ -56,9 +56,8 @@ package System.Finalization_Masters is type FM_Node_Ptr is access all FM_Node; type FM_Node is record - Prev : FM_Node_Ptr := null; - Next : FM_Node_Ptr := null; - Finalize_Address : Finalize_Address_Ptr := null; + Prev : FM_Node_Ptr := null; + Next : FM_Node_Ptr := null; end record; -- A reference to any derivation from Root_Storage_Pool. Since this type @@ -83,6 +82,9 @@ package System.Finalization_Masters is -- A doubly linked list which contains the headers of all controlled -- objects allocated in a [sub]pool. + Finalize_Address : Finalize_Address_Ptr := null; + -- A reference to the routine reponsible for object finalization + Finalization_Started : Boolean := False; pragma Atomic (Finalization_Started); -- A flag used to detect allocations which occur during the finalization @@ -120,12 +122,12 @@ package System.Finalization_Masters is -- the list of allocated controlled objects, finalizing each one by calling -- its specific Finalize_Address. In the end, deallocate the dummy head. - function Header_Size return System.Storage_Elements.Storage_Count; - -- Return the size of type FM_Node as Storage_Count - function Header_Offset return System.Storage_Elements.Storage_Offset; -- Return the size of type FM_Node as Storage_Offset + function Header_Size return System.Storage_Elements.Storage_Count; + -- Return the size of type FM_Node as Storage_Count + overriding procedure Initialize (Master : in out Finalization_Master); -- Initialize the dummy head of a finalization master diff --git a/gcc/ada/s-stposu.adb b/gcc/ada/s-stposu.adb index d52625f..4fb0b96 100644 --- a/gcc/ada/s-stposu.adb +++ b/gcc/ada/s-stposu.adb @@ -247,10 +247,12 @@ package body System.Storage_Pools.Subpools is -- | | -- +- Header_And_Padding --+ - N_Ptr := - Address_To_FM_Node_Ptr (N_Addr + Header_And_Padding - Header_Size); + N_Ptr := Address_To_FM_Node_Ptr + (N_Addr + Header_And_Padding - Header_Offset); - N_Ptr.Finalize_Address := Fin_Address; + if Master.Finalize_Address = null then + Master.Finalize_Address := Fin_Address; + end if; -- Prepend the allocated object to the finalization master @@ -334,7 +336,7 @@ package body System.Storage_Pools.Subpools is -- Convert the bits preceding the object into a list header - N_Ptr := Address_To_FM_Node_Ptr (Addr - Header_Size); + N_Ptr := Address_To_FM_Node_Ptr (Addr - Header_Offset); -- Detach the object from the related finalization master. This -- action does not need to know the prior context used during diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index d6eb55d..a4b0c3c 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -4716,7 +4716,7 @@ package body Sem_Ch6 is -- Grouping (use of comma in param lists) must be the same -- This is where we catch a misconformance like: - -- A,B : Integer + -- A, B : Integer -- A : Integer; B : Integer -- which are represented identically in the tree except diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 9c8d9c5..e6730f2 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -4168,6 +4168,15 @@ package body Sem_Util is end if; end Get_Actual_Subtype_If_Available; + ------------------------ + -- Get_Body_From_Stub -- + ------------------------ + + function Get_Body_From_Stub (N : Node_Id) return Node_Id is + begin + return Proper_Body (Unit (Library_Unit (N))); + end Get_Body_From_Stub; + ------------------------------- -- Get_Default_External_Name -- ------------------------------- @@ -7939,6 +7948,22 @@ package body Sem_Util is or else Nkind (N) = N_Procedure_Call_Statement; end Is_Statement; + -------------------------------------------------- + -- Is_Subprogram_Stub_Without_Prior_Declaration -- + -------------------------------------------------- + + function Is_Subprogram_Stub_Without_Prior_Declaration + (N : Node_Id) return Boolean is + + begin + -- A subprogram stub without prior declaration serves as declaration for + -- the actual subprogram body. As such, it has an attached defining + -- entity of E_[Generic_]Function or E_[Generic_]Procedure. + + return Nkind (N) = N_Subprogram_Body_Stub + and then Ekind (Defining_Entity (N)) /= E_Subprogram_Body; + end Is_Subprogram_Stub_Without_Prior_Declaration; + --------------------------------- -- Is_Synchronized_Tagged_Type -- --------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 1d0d23e..bc36fb2 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -479,6 +479,9 @@ package Sem_Util is -- Actual_Subtype field of the corresponding entity is set, then it is -- returned. Otherwise the Etype of the node is returned. + function Get_Body_From_Stub (N : Node_Id) return Node_Id; + -- Return the body node for a stub (subprogram or package) + function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id; -- This is used to construct the string literal node representing a -- default external name, i.e. one that is constructed from the name of an @@ -884,6 +887,11 @@ package Sem_Util is -- the N_Statement_Other_Than_Procedure_Call subtype from Sinfo). -- Note that a label is *not* a statement, and will return False. + function Is_Subprogram_Stub_Without_Prior_Declaration + (N : Node_Id) return Boolean; + -- Return True if N is a subprogram stub with no prior subprogram + -- declaration. + function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean; -- Returns True if E is a synchronized tagged type (AARM 3.9.4 (6/2)) diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 0fee04c..044efd8 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -3340,12 +3340,12 @@ package body Sem_Warn is if Is_Elementary_Type (Etype (Act1)) and then Ekind (Form2) = E_In_Parameter then - null; -- no real aliasing. + null; -- No real aliasing elsif Is_Elementary_Type (Etype (Act2)) and then Ekind (Form2) = E_In_Parameter then - null; -- ditto + null; -- Ditto -- If the call was written in prefix notation, and -- thus its prefix before rewriting was a selected -- 2.7.4