From: Arnaud Charlet Date: Thu, 4 Aug 2011 07:45:20 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=824e9320157031e3969aabe742cfddd38a0513cd;p=gcc.git [multiple changes] 2011-08-04 Emmanuel Briot * prj-proc.adb, prj-nmsc.adb, prj-env.adb (Process_Declarative_Items): Add support for overriding the Project_Path in aggregate projects. 2011-08-04 Robert Dewar * a-cofove.ads: Minor reformatting. 2011-08-04 Hristian Kirtchev * exp_ch7.adb (Build_Adjust_Or_Finalize_Statements): Update the comment on the generated code. (Build_Finalize_Statements): Update the comment on the generated code. (Build_Initialize_Statements): Update the comment on the generated code. (Build_Object_Declarations): Add local variable Result. The object declarations are now built in sequence. * rtsfind.ads: Add RE_Exception_Occurrence_Access to tables RE_Id and RE_Unit_Table. 2011-08-04 Robert Dewar * checks.adb, alfa.adb, alfa.ads: Minor reformatting. 2011-08-04 Eric Botcazou * einfo.ads (Elaboration_Entity): Document new definition and use. (Elaboration_Entity_Required): Adjust to above change. * exp_attr.adb (Expand_N_Attribute_Reference): Likewise. * exp_ch12.adb: And with and use for Snames. (Expand_N_Generic_Instantiation): Test 'Elaborated attribute. * exp_util.adb (Set_Elaboration_Flag): Likewise. * sem_attr.adb (Analyze_Attribute) : Delete. : Deal with N_Expanded_Name. : Extend to all unit names. * sem_elab.adb: And with and use for Uintp. (Check_Internal_Call_Continue): Adjust to Elaboration_Entity change. * sem_util.ads (Build_Elaboration_Entity): Adjust comment. * sem_util.adb (Build_Elaboration_Entity): Change type to Integer. * bindgen.adb (Gen_Elab_Externals_Ada): New local subprogram taken from Gen_Adainit_Ada. (Gen_Elab_Externals_C): Likewise, but taken from Gen_Adainit_C. (Gen_Adafinal_Ada): Remove redundant test. In the non-main program case, do not call System.Standard_Library.Adafinal; instead call finalize_library if needed. (Gen_Adafinal_C): Likewise. (Gen_Adainit_Ada): Do not set SSL.Finalize_Library_Objects in the non-main program case. (Gen_Adainit_C): Generate a couple of external declarations here. In the main program case, set SSL.Finalize_Library_Objects. (Gen_Elab_Calls_Ada): Adjust to Elaboration_Entity change. (Gen_Elab_Calls_C): Likewise. (Gen_Finalize_Library_Ada): Likewise. Skip SAL interface units. (Gen_Finalize_Library_C): Likewise. Generate a full function. (Gen_Main_C): Put back call to Ada_Final and don't finalize library objects here. (Gen_Output_File_Ada): Generate pragma Linker_Destructor for Ada_Final if -a is specified. Call Gen_Elab_Externals_Ada. Move around call to Gen_Adafinal_Ada. (Gen_Output_File_C): Generate __attribute__((destructor)) for Ada_Final if -a is specified. Call Gen_Elab_Externals_C. Remove useless couple of external declarations.  Call Gen_Finalize_Library_C. From-SVN: r177318 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 40ffac4e364..e318a9490a7 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,66 @@ +2011-08-04 Emmanuel Briot + + * prj-proc.adb, prj-nmsc.adb, prj-env.adb (Process_Declarative_Items): + Add support for overriding the Project_Path in aggregate projects. + +2011-08-04 Robert Dewar + + * a-cofove.ads: Minor reformatting. + +2011-08-04 Hristian Kirtchev + + * exp_ch7.adb (Build_Adjust_Or_Finalize_Statements): Update the comment + on the generated code. + (Build_Finalize_Statements): Update the comment on the generated code. + (Build_Initialize_Statements): Update the comment on the generated code. + (Build_Object_Declarations): Add local variable Result. The object + declarations are now built in sequence. + * rtsfind.ads: Add RE_Exception_Occurrence_Access to tables RE_Id and + RE_Unit_Table. + +2011-08-04 Robert Dewar + + * checks.adb, alfa.adb, alfa.ads: Minor reformatting. + +2011-08-04 Eric Botcazou + + * einfo.ads (Elaboration_Entity): Document new definition and use. + (Elaboration_Entity_Required): Adjust to above change. + * exp_attr.adb (Expand_N_Attribute_Reference): Likewise. + * exp_ch12.adb: And with and use for Snames. + (Expand_N_Generic_Instantiation): Test 'Elaborated attribute. + * exp_util.adb (Set_Elaboration_Flag): Likewise. + * sem_attr.adb (Analyze_Attribute) : Delete. + : Deal with N_Expanded_Name. + : Extend to all unit names. + * sem_elab.adb: And with and use for Uintp. + (Check_Internal_Call_Continue): Adjust to Elaboration_Entity change. + * sem_util.ads (Build_Elaboration_Entity): Adjust comment. + * sem_util.adb (Build_Elaboration_Entity): Change type to Integer. + * bindgen.adb (Gen_Elab_Externals_Ada): New local subprogram taken + from Gen_Adainit_Ada. + (Gen_Elab_Externals_C): Likewise, but taken from Gen_Adainit_C. + (Gen_Adafinal_Ada): Remove redundant test. In the non-main program + case, do not call System.Standard_Library.Adafinal; instead call + finalize_library if needed. + (Gen_Adafinal_C): Likewise. + (Gen_Adainit_Ada): Do not set SSL.Finalize_Library_Objects in the + non-main program case. + (Gen_Adainit_C): Generate a couple of external declarations here. + In the main program case, set SSL.Finalize_Library_Objects. + (Gen_Elab_Calls_Ada): Adjust to Elaboration_Entity change. + (Gen_Elab_Calls_C): Likewise. + (Gen_Finalize_Library_Ada): Likewise. Skip SAL interface units. + (Gen_Finalize_Library_C): Likewise. Generate a full function. + (Gen_Main_C): Put back call to Ada_Final and don't finalize library + objects here. + (Gen_Output_File_Ada): Generate pragma Linker_Destructor for Ada_Final + if -a is specified. Call Gen_Elab_Externals_Ada. Move around call to + Gen_Adafinal_Ada. + (Gen_Output_File_C): Generate __attribute__((destructor)) for Ada_Final + if -a is specified. Call Gen_Elab_Externals_C. Remove useless couple + of external declarations.  Call Gen_Finalize_Library_C. + 2011-08-04 Emmanuel Briot * prj.adb, prj.ads, makeutl.adb, makeutl.ads (Complete_Mains, diff --git a/gcc/ada/a-cofove.ads b/gcc/ada/a-cofove.ads index 8dcb7475163..24e2944fb7e 100644 --- a/gcc/ada/a-cofove.ads +++ b/gcc/ada/a-cofove.ads @@ -143,8 +143,9 @@ package Ada.Containers.Formal_Vectors is (Container : Vector; Index : Index_Type) return Element_Type; - function Element (Container : Vector; Position : Cursor) - return Element_Type; + function Element + (Container : Vector; + Position : Cursor) return Element_Type; procedure Replace_Element (Container : in out Vector; @@ -388,7 +389,7 @@ private for Vector'Read use Read; type Cursor is record - Valid : Boolean := True; + Valid : Boolean := True; Index : Index_Type := Index_Type'First; end record; diff --git a/gcc/ada/alfa.adb b/gcc/ada/alfa.adb index 9030d000868..065b7d8c5bb 100644 --- a/gcc/ada/alfa.adb +++ b/gcc/ada/alfa.adb @@ -144,17 +144,6 @@ package body ALFA is end loop; end dalfa; - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize_ALFA_Tables is - begin - ALFA_File_Table.Init; - ALFA_Scope_Table.Init; - ALFA_Xref_Table.Init; - end Initialize_ALFA_Tables; - ------------------------- -- Get_Entity_For_Decl -- ------------------------- @@ -223,6 +212,17 @@ package body ALFA is return E; end Get_Unique_Entity_For_Decl; + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize_ALFA_Tables is + begin + ALFA_File_Table.Init; + ALFA_Scope_Table.Init; + ALFA_Xref_Table.Init; + end Initialize_ALFA_Tables; + ----------- -- palfa -- ----------- diff --git a/gcc/ada/alfa.ads b/gcc/ada/alfa.ads index 1813a795fdf..5ad7c61c1a6 100644 --- a/gcc/ada/alfa.ads +++ b/gcc/ada/alfa.ads @@ -316,10 +316,6 @@ package ALFA is -- Subprograms -- ----------------- - procedure dalfa; - -- Debug routine to dump internal ALFA tables. This is a raw format dump - -- showing exactly what the tables contain. - procedure Initialize_ALFA_Tables; -- Reset tables for a new compilation @@ -330,6 +326,10 @@ package ALFA is -- Return the entity which represents declaration N, so that matching -- declaration and body have the same entity. + procedure dalfa; + -- Debug routine to dump internal ALFA tables. This is a raw format dump + -- showing exactly what the tables contain. + procedure palfa; -- Debugging procedure to output contents of ALFA binary tables in the -- format in which they appear in an ALI file. diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index b88ed0019f7..9072e36f06a 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -72,6 +72,7 @@ package body Bindgen is -- unit unconditionally, which is unpleasand, especially for ZFP etc.) Lib_Final_Built : Boolean := False; + -- Flag indicating whether the finalize_library rountine has been built ---------------------------------- -- Interface_State Pragma Table -- @@ -244,6 +245,12 @@ package body Bindgen is procedure Gen_Adafinal_C; -- Generate the Adafinal procedure (C code case) + procedure Gen_Elab_Externals_Ada; + -- Generate sequence of external declarations for elaboration (Ada) + + procedure Gen_Elab_Externals_C; + -- Generate sequence of external declarations for elaboration (C) + procedure Gen_Elab_Calls_Ada; -- Generate sequence of elaboration calls (Ada code case) @@ -421,13 +428,15 @@ package body Bindgen is begin WBI (" procedure " & Ada_Final_Name.all & " is"); - -- Do nothing if finalization is disabled - - if Cumulative_Restrictions.Set (No_Finalization) then + if not Bind_Main_Program then WBI (" begin"); - WBI (" null;"); + if Lib_Final_Built then + WBI (" finalize_library;"); + else + WBI (" null;"); + end if; - -- General case + -- Main program case elsif VM_Target = No_VM then WBI (" procedure s_stalib_adafinal;"); @@ -455,7 +464,17 @@ package body Bindgen is procedure Gen_Adafinal_C is begin WBI ("void " & Ada_Final_Name.all & " (void) {"); - WBI (" system__standard_library__adafinal ();"); + + if not Bind_Main_Program then + if Lib_Final_Built then + WBI (" finalize_library ();"); + end if; + + -- Main program case + + else + WBI (" system__standard_library__adafinal ();"); + end if; WBI ("}"); WBI (""); end Gen_Adafinal_C; @@ -471,86 +490,6 @@ package body Bindgen is begin WBI (" procedure " & Ada_Init_Name.all & " is"); - -- Generate externals for elaboration entities - - for E in Elab_Order.First .. Elab_Order.Last loop - declare - Unum : constant Unit_Id := Elab_Order.Table (E); - U : Unit_Record renames Units.Table (Unum); - - begin - -- Check for Elab_Entity to be set for this unit - - if U.Set_Elab_Entity - - -- Don't generate reference for stand alone library - - and then not U.SAL_Interface - - -- Don't generate reference for predefined file in No_Run_Time - -- mode, since we don't include the object files in this case - - and then not - (No_Run_Time_Mode - and then Is_Predefined_File_Name (U.Sfile)) - then - Set_String (" "); - Set_String ("E"); - Set_Unit_Number (Unum); - - case VM_Target is - when No_VM | JVM_Target => - Set_String (" : Boolean; pragma Import (Ada, "); - when CLI_Target => - Set_String (" : Boolean; pragma Import (CIL, "); - end case; - - Set_String ("E"); - Set_Unit_Number (Unum); - Set_String (", """); - Get_Name_String (U.Uname); - - -- In the case of JGNAT we need to emit an Import name that - -- includes the class name (using '$' separators in the case - -- of a child unit name). - - if VM_Target /= No_VM then - for J in 1 .. Name_Len - 2 loop - if VM_Target = CLI_Target - or else Name_Buffer (J) /= '.' - then - Set_Char (Name_Buffer (J)); - else - Set_String ("$"); - end if; - end loop; - - if VM_Target /= CLI_Target or else U.Unit_Kind = 's' then - Set_String ("."); - else - Set_String ("_pkg."); - end if; - - -- If the unit name is very long, then split the - -- Import link name across lines using "&" (occurs - -- in some C2 tests). - - if 2 * Name_Len + 60 > Hostparm.Max_Line_Length then - Set_String (""" &"); - Write_Statement_Buffer; - Set_String (" """); - end if; - end if; - - Set_Unit_Name; - Set_String ("_E"");"); - Write_Statement_Buffer; - end if; - end; - end loop; - - Write_Statement_Buffer; - -- If the standard library is suppressed, then the only global variables -- that might be needed (by the Ravenscar profile) are the priority and -- the processor for the environment task. @@ -927,38 +866,39 @@ package body Bindgen is WBI (" Initialize_Stack_Limit;"); end if; - -- Attach Finalize_Library to the right soft link. Do it only when not - -- using a restricted run time, in which case tasks are - -- non-terminating, so we do not want library-level finalization. + -- In the main program case, attach finalize_library to the soft link. + -- Do it only when not using a restricted run time, in which case tasks + -- are non-terminating, so we do not want library-level finalization. - if not Configurable_Run_Time_On_Target then - if not Suppress_Standard_Library_On_Target then - WBI (""); + if Bind_Main_Program + and then not Configurable_Run_Time_On_Target + and then not Suppress_Standard_Library_On_Target + then + WBI (""); - if VM_Target = No_VM then - if Lib_Final_Built then - Set_String (" Finalize_Library_Objects := "); - Set_String ("Finalize_Library'access;"); - else - Set_String (" Finalize_Library_Objects := null;"); - end if; + if VM_Target = No_VM then + if Lib_Final_Built then + Set_String (" Finalize_Library_Objects := "); + Set_String ("finalize_library'access;"); + else + Set_String (" Finalize_Library_Objects := null;"); + end if; - -- On VM targets use regular Ada to set the soft link + -- On VM targets use regular Ada to set the soft link + else + if Lib_Final_Built then + Set_String + (" System.Soft_Links.Finalize_Library_Objects"); + Set_String (" := finalize_library'access;"); else - if Lib_Final_Built then - Set_String - (" System.Soft_Links.Finalize_Library_Objects"); - Set_String (" := Finalize_Library'access;"); - else - Set_String - (" System.Soft_Links.Finalize_Library_Objects"); - Set_String (" := null;"); - end if; + Set_String + (" System.Soft_Links.Finalize_Library_Objects"); + Set_String (" := null;"); end if; - - Write_Statement_Buffer; end if; + + Write_Statement_Buffer; end if; -- Generate elaboration calls @@ -1001,40 +941,6 @@ package body Bindgen is WBI ("void " & Ada_Init_Name.all & " (void)"); WBI ("{"); - -- Generate externals for elaboration entities - - for E in Elab_Order.First .. Elab_Order.Last loop - declare - Unum : constant Unit_Id := Elab_Order.Table (E); - U : Unit_Record renames Units.Table (Unum); - - begin - -- Check for Elab entity to be set for this unit - - if U.Set_Elab_Entity - - -- Don't generate reference for stand alone library - - and then not U.SAL_Interface - - -- Don't generate reference for predefined file in No_Run_Time - -- mode, since we don't include the object files in this case - - and then not - (No_Run_Time_Mode - and then Is_Predefined_File_Name (U.Sfile)) - then - Set_String (" extern char "); - Get_Name_String (U.Uname); - Set_Unit_Name; - Set_String ("_E;"); - Write_Statement_Buffer; - end if; - end; - end loop; - - Write_Statement_Buffer; - -- Standard library suppressed if Suppress_Standard_Library_On_Target then @@ -1217,22 +1123,26 @@ package body Bindgen is Set_String (";"); Write_Statement_Buffer; + -- Import entry point for elaboration time signal handler + -- installation, and indication of if it's been called previously. + + WBI (" extern int __gnat_handler_installed;"); WBI (""); -- Install elaboration time signal handler WBI (" if (__gnat_handler_installed == 0)"); - WBI (" {"); - WBI (" __gnat_install_handler ();"); - WBI (" }"); + WBI (" __gnat_install_handler ();"); - -- Call feature enable/disable routine + -- Import entry point for environment feature enable/disable + -- routine, and indication that it's been called previously. if OpenVMS_On_Target then + WBI (" extern int __gnat_features_set;"); + WBI (""); + WBI (" if (__gnat_features_set == 0)"); - WBI (" {"); - WBI (" __gnat_set_features ();"); - WBI (" }"); + WBI (" __gnat_set_features ();"); end if; end if; @@ -1269,6 +1179,27 @@ package body Bindgen is Write_Statement_Buffer; end if; + -- In the main program case, attach finalize_library to the soft link. + -- Do it only when not using a restricted run time, in which case tasks + -- are non-terminating, so we do not want library-level finalization. + + if Bind_Main_Program + and then not Configurable_Run_Time_On_Target + and then not Suppress_Standard_Library_On_Target + then + WBI (""); + WBI (" extern void (*__gnat_finalize_library_objects)(void);"); + + if Lib_Final_Built then + Set_String (" __gnat_finalize_library_objects = "); + Set_String ("&finalize_library;"); + else + Set_String (" __gnat_finalize_library_objects = 0;"); + end if; + + Write_Statement_Buffer; + end if; + -- Generate elaboration calls WBI (""); @@ -1277,6 +1208,130 @@ package body Bindgen is WBI (""); end Gen_Adainit_C; + ---------------------------- + -- Gen_Elab_Externals_Ada -- + ---------------------------- + + procedure Gen_Elab_Externals_Ada is + begin + for E in Elab_Order.First .. Elab_Order.Last loop + declare + Unum : constant Unit_Id := Elab_Order.Table (E); + U : Unit_Record renames Units.Table (Unum); + + begin + -- Check for Elab_Entity to be set for this unit + + if U.Set_Elab_Entity + + -- Don't generate reference for stand alone library + + and then not U.SAL_Interface + + -- Don't generate reference for predefined file in No_Run_Time + -- mode, since we don't include the object files in this case + + and then not + (No_Run_Time_Mode + and then Is_Predefined_File_Name (U.Sfile)) + then + Set_String (" "); + Set_String ("E"); + Set_Unit_Number (Unum); + + case VM_Target is + when No_VM | JVM_Target => + Set_String (" : Integer; pragma Import (Ada, "); + when CLI_Target => + Set_String (" : Integer; pragma Import (CIL, "); + end case; + + Set_String ("E"); + Set_Unit_Number (Unum); + Set_String (", """); + Get_Name_String (U.Uname); + + -- In the case of JGNAT we need to emit an Import name that + -- includes the class name (using '$' separators in the case + -- of a child unit name). + + if VM_Target /= No_VM then + for J in 1 .. Name_Len - 2 loop + if VM_Target = CLI_Target + or else Name_Buffer (J) /= '.' + then + Set_Char (Name_Buffer (J)); + else + Set_String ("$"); + end if; + end loop; + + if VM_Target /= CLI_Target or else U.Unit_Kind = 's' then + Set_String ("."); + else + Set_String ("_pkg."); + end if; + + -- If the unit name is very long, then split the + -- Import link name across lines using "&" (occurs + -- in some C2 tests). + + if 2 * Name_Len + 60 > Hostparm.Max_Line_Length then + Set_String (""" &"); + Write_Statement_Buffer; + Set_String (" """); + end if; + end if; + + Set_Unit_Name; + Set_String ("_E"");"); + Write_Statement_Buffer; + end if; + end; + end loop; + + WBI (""); + end Gen_Elab_Externals_Ada; + + -------------------------- + -- Gen_Elab_Externals_C -- + -------------------------- + + procedure Gen_Elab_Externals_C is + begin + for E in Elab_Order.First .. Elab_Order.Last loop + declare + Unum : constant Unit_Id := Elab_Order.Table (E); + U : Unit_Record renames Units.Table (Unum); + + begin + -- Check for Elab entity to be set for this unit + + if U.Set_Elab_Entity + + -- Don't generate reference for stand alone library + + and then not U.SAL_Interface + + -- Don't generate reference for predefined file in No_Run_Time + -- mode, since we don't include the object files in this case + + and then not + (No_Run_Time_Mode + and then Is_Predefined_File_Name (U.Sfile)) + then + Set_String ("extern int "); + Get_Name_String (U.Uname); + Set_Unit_Name; + Set_String ("_E;"); + Write_Statement_Buffer; + end if; + end; + end loop; + + WBI (""); + end Gen_Elab_Externals_C; + ------------------------ -- Gen_Elab_Calls_Ada -- ------------------------ @@ -1306,51 +1361,55 @@ package body Bindgen is if No_Run_Time_Mode and then Is_Predefined_File_Name (U.Sfile) then null; + -- Likewise if this is an interface to a stand alone library + + elsif U.SAL_Interface then + null; + -- Case of no elaboration code elsif U.No_Elab then - -- The only case in which we have to do something is if - -- this is a body, with a separate spec, where the separate - -- spec has an elaboration entity defined. + -- The only case in which we have to do something is if this + -- is a body, with a separate spec, where the separate spec + -- has an elaboration entity defined. In that case, this is + -- where we increment the elaboration entity. - -- In that case, this is where we set the elaboration entity - -- to True, we do not need to test if this has already been - -- done, since it is quicker to set the flag than to test it. - - if not U.SAL_Interface and then U.Utype = Is_Body + if U.Utype = Is_Body and then Units.Table (Unum_Spec).Set_Elab_Entity then Set_String (" E"); Set_Unit_Number (Unum_Spec); - Set_String (" := True;"); + Set_String (" := E"); + Set_Unit_Number (Unum_Spec); + Set_String (" + 1;"); Write_Statement_Buffer; end if; -- Here if elaboration code is present. If binding a library -- or if there is a non-Ada main subprogram then we generate: - -- if not uname_E then + -- if uname_E = 0 then -- uname'elab_[spec|body]; - -- uname_E := True; -- end if; + -- uname_E := uname_E + 1; -- Otherwise, elaboration routines are called unconditionally: -- uname'elab_[spec|body]; - -- uname_E := True; + -- uname_E := uname_E + 1; - -- The uname_E assignment is skipped if this is a separate spec, - -- since the assignment will be done when we process the body. + -- The uname_E increment is skipped if this is a separate spec, + -- since it will be done when we process the body. - elsif not U.SAL_Interface then + else if Force_Checking_Of_Elaboration_Flags or Interface_Library_Unit or (not Bind_Main_Program) then - Set_String (" if not E"); + Set_String (" if E"); Set_Unit_Number (Unum_Spec); - Set_String (" then"); + Set_String (" = 0 then"); Write_Statement_Buffer; Set_String (" "); end if; @@ -1386,26 +1445,21 @@ package body Bindgen is Set_Char (';'); Write_Statement_Buffer; - if U.Utype /= Is_Spec then - if Force_Checking_Of_Elaboration_Flags or - Interface_Library_Unit or - (not Bind_Main_Program) - then - Set_String (" "); - end if; - - Set_String (" E"); - Set_Unit_Number (Unum_Spec); - Set_String (" := True;"); - Write_Statement_Buffer; - end if; - if Force_Checking_Of_Elaboration_Flags or Interface_Library_Unit or (not Bind_Main_Program) then WBI (" end if;"); end if; + + if U.Utype /= Is_Spec then + Set_String (" E"); + Set_Unit_Number (Unum_Spec); + Set_String (" := E"); + Set_Unit_Number (Unum_Spec); + Set_String (" + 1;"); + Write_Statement_Buffer; + end if; end if; end; end loop; @@ -1440,40 +1494,47 @@ package body Bindgen is if No_Run_Time_Mode and then Is_Predefined_File_Name (U.Sfile) then null; + -- Likewise if this is an interface to a stand alone library + + elsif U.SAL_Interface then + null; + -- Case of no elaboration code elsif U.No_Elab then - -- The only case in which we have to do something is if - -- this is a body, with a separate spec, where the separate - -- spec has an elaboration entity defined. + -- The only case in which we have to do something is if this + -- is a body, with a separate spec, where the separate spec + -- has an elaboration entity defined. In that case, this is + -- where we increment the elaboration entity. - -- In that case, this is where we set the elaboration entity - -- to True, we do not need to test if this has already been - -- done, since it is quicker to set the flag than to test it. - - if not U.SAL_Interface and then U.Utype = Is_Body + if U.Utype = Is_Body and then Units.Table (Unum_Spec).Set_Elab_Entity then - Set_String (" "); Get_Name_String (U.Uname); + + Set_String (" "); Set_Unit_Name; - Set_String ("_E = 1;"); + Set_String ("_E++;"); Write_Statement_Buffer; end if; -- Here if elaboration code is present. If binding a library -- or if there is a non-Ada main subprogram then we generate: - -- if (uname_E == 0) { + -- if (uname_E == 0) -- uname__elab[s|b] (); - -- uname_E++; - -- } + -- uname_E++; + + -- Otherwise, elaboration routines are called unconditionally: - -- The uname_E assignment is skipped if this is a separate spec, - -- since the assignment will be done when we process the body. + -- uname__elab[s|b] (); + -- uname_E++; - elsif not U.SAL_Interface then + -- The uname_E increment is skipped if this is a separate spec, + -- since it will be done when we process the body. + + else Get_Name_String (U.Uname); if Force_Checking_Of_Elaboration_Flags or @@ -1482,7 +1543,7 @@ package body Bindgen is then Set_String (" if ("); Set_Unit_Name; - Set_String ("_E == 0) {"); + Set_String ("_E == 0)"); Write_Statement_Buffer; Set_String (" "); end if; @@ -1495,25 +1556,11 @@ package body Bindgen is Write_Statement_Buffer; if U.Utype /= Is_Spec then - if Force_Checking_Of_Elaboration_Flags or - Interface_Library_Unit or - (not Bind_Main_Program) - then - Set_String (" "); - end if; - Set_String (" "); Set_Unit_Name; Set_String ("_E++;"); Write_Statement_Buffer; end if; - - if Force_Checking_Of_Elaboration_Flags or - Interface_Library_Unit or - (not Bind_Main_Program) - then - WBI (" }"); - end if; end if; end; end loop; @@ -1542,6 +1589,8 @@ package body Bindgen is Write_Statement_Buffer; end if; end loop; + + WBI ("/* END ELABORATION DEFINITIONS */"); WBI (""); end Gen_Elab_Defs_C; @@ -1602,12 +1651,13 @@ package body Bindgen is if U.Unit_Kind = 'p' and then U.Has_Finalizer and then not U.Is_Generic + and then not U.SAL_Interface and then not U.No_Elab then if not Lib_Final_Built then Lib_Final_Built := True; - WBI (" procedure Finalize_Library is"); + WBI (" procedure finalize_library is"); -- The following flag is used to check for library-level -- exceptions raised during finalization. The symbol comes @@ -1708,16 +1758,48 @@ package body Bindgen is Set_String (""");"); Write_Statement_Buffer; - WBI (" begin"); + -- If binding a library or if there is a non-Ada main subprogram + -- then we generate: - -- Generate: + -- begin + -- uname_E := uname_E - 1; + -- if uname_E = 0 then + -- F; + -- end if; + -- end; + + -- Otherwise, finalization routines are called unconditionally: + + -- begin + -- uname_E := uname_E - 1; -- F; -- end; + WBI (" begin"); + Set_String (" E"); + Set_Unit_Number (Unum); + Set_String (" := E"); + Set_Unit_Number (Unum); + Set_String (" - 1;"); + Write_Statement_Buffer; + + if Interface_Library_Unit or (not Bind_Main_Program) then + Set_String (" if E"); + Set_Unit_Number (Unum); + Set_String (" = 0 then"); + Write_Statement_Buffer; + Set_String (" "); + end if; + Set_String (" F"); Set_Int (Count); Set_Char (';'); Write_Statement_Buffer; + + if Interface_Library_Unit or (not Bind_Main_Program) then + WBI (" end if;"); + end if; + WBI (" end;"); Count := Count + 1; @@ -1762,7 +1844,7 @@ package body Bindgen is end if; WBI (" end if;"); - WBI (" end Finalize_Library;"); + WBI (" end finalize_library;"); WBI (""); end if; end Gen_Finalize_Library_Ada; @@ -1777,8 +1859,6 @@ package body Bindgen is Unum : Unit_Id; begin - WBI (" /* BEGIN FINALIZE */"); - for E in reverse Elab_Order.First .. Elab_Order.Last loop Unum := Elab_Order.Table (E); U := Units.Table (Unum); @@ -1788,9 +1868,14 @@ package body Bindgen is if U.Unit_Kind = 'p' and then U.Has_Finalizer and then not U.Is_Generic + and then not U.SAL_Interface and then not U.No_Elab then - Set_String (" "); + if not Lib_Final_Built then + Lib_Final_Built := True; + + WBI ("static void finalize_library(void) {"); + end if; -- Dealing with package bodies is a little complicated. In such -- cases we must retrieve the package spec since it contains the @@ -1803,6 +1888,34 @@ package body Bindgen is Uspec := U; end if; + Get_Name_String (Uspec.Uname); + + -- If binding a library or if there is a non-Ada main subprogram + -- then we generate: + + -- uname_E--; + -- if (uname_E == 0) + -- uname__finalize[S|B] (); + + -- Otherwise, finalization routines are called unconditionally: + + -- uname_E--; + -- uname__finalize[S|B] (); + + Set_String (" "); + Set_Unit_Name; + Set_String ("_E--;"); + Write_Statement_Buffer; + + if Interface_Library_Unit or (not Bind_Main_Program) then + Set_String (" if ("); + Set_Unit_Name; + Set_String ("_E == 0)"); + Write_Statement_Buffer; + Set_String (" "); + end if; + + Set_String (" "); Get_Name_String (Uspec.Uname); Set_Unit_Name; Set_String ("__finalize"); @@ -1826,8 +1939,10 @@ package body Bindgen is end if; end loop; - WBI (" /* END FINALIZE */"); - WBI (""); + if Lib_Final_Built then + WBI ("}"); + WBI (""); + end if; end Gen_Finalize_Library_C; --------------------------------- @@ -2124,15 +2239,10 @@ package body Bindgen is ---------------- procedure Gen_Main_C is - Needs_Library_Finalization : constant Boolean := - not Configurable_Run_Time_On_Target - and then Has_Finalizer; - -- For restricted run-time libraries (ZFP and Ravenscar) tasks are - -- non-terminating, so we do not want library-level finalization. - begin if Exit_Status_Supported_On_Target then WBI ("#include "); + WBI (""); Set_String ("int "); else Set_String ("void "); @@ -2190,7 +2300,7 @@ package body Bindgen is WBI (" gnat_argc = argc;"); WBI (" gnat_argv = argv;"); WBI (" gnat_envp = envp;"); - WBI (" "); + WBI (""); -- If configurable run-time, then nothing to do, since in this case -- the gnat_argc/argv/envp variables are entirely suppressed. @@ -2239,7 +2349,6 @@ package body Bindgen is if not No_Main_Subprogram then WBI (" __gnat_break_start ();"); - WBI (" "); -- Output main program name @@ -2266,10 +2375,8 @@ package body Bindgen is -- Call adafinal if finalization active - if not Cumulative_Restrictions.Set (No_Finalization) - and then Needs_Library_Finalization - then - Gen_Finalize_Library_C; + if not Cumulative_Restrictions.Set (No_Finalization) then + WBI (" " & Ada_Final_Name.all & " ();"); end if; -- Outputs the dynamic stack measurement if needed @@ -2798,29 +2905,29 @@ package body Bindgen is """__gnat_ada_main_program_name"");"); end if; - if not Cumulative_Restrictions.Set (No_Finalization) then - WBI (""); - WBI (" procedure " & Ada_Final_Name.all & ";"); - WBI (" pragma Export (C, " & Ada_Final_Name.all & ", """ & - Ada_Final_Name.all & """);"); - end if; - WBI (""); WBI (" procedure " & Ada_Init_Name.all & ";"); WBI (" pragma Export (C, " & Ada_Init_Name.all & ", """ & Ada_Init_Name.all & """);"); -- If -a has been specified use pragma Linker_Constructor for the init - -- procedure. No need to use a similar pragma for the final procedure as - -- global finalization will occur when the executable finishes execution - -- and for plugins (shared stand-alone libraries that can be - -- "unloaded"), finalization should not occur automatically, otherwise - -- the main executable may not continue to work properly. + -- procedure and pragma Linker_Destructor for the final procedure. if Use_Pragma_Linker_Constructor then WBI (" pragma Linker_Constructor (" & Ada_Init_Name.all & ");"); end if; + if not Cumulative_Restrictions.Set (No_Finalization) then + WBI (""); + WBI (" procedure " & Ada_Final_Name.all & ";"); + WBI (" pragma Export (C, " & Ada_Final_Name.all & ", """ & + Ada_Final_Name.all & """);"); + + if Use_Pragma_Linker_Constructor then + WBI (" pragma Linker_Destructor (" & Ada_Final_Name.all & ");"); + end if; + end if; + if Bind_Main_Program and then VM_Target = No_VM then -- If we have the standard library, then Break_Start is defined @@ -2933,6 +3040,10 @@ package body Bindgen is WBI (""); WBI ("package body " & Ada_Main & " is"); WBI (" pragma Warnings (Off);"); + WBI (""); + + -- Generate externals for elaboration entities + Gen_Elab_Externals_Ada; if not Suppress_Standard_Library_On_Target then @@ -2964,11 +3075,11 @@ package body Bindgen is -- Generate the adafinal routine unless there is no finalization to do if not Cumulative_Restrictions.Set (No_Finalization) then - Gen_Adafinal_Ada; - if Needs_Library_Finalization then Gen_Finalize_Library_Ada; end if; + + Gen_Adafinal_Ada; end if; Gen_Adainit_Ada; @@ -3019,14 +3130,8 @@ package body Bindgen is Resolve_Binder_Options; - WBI ("extern void " & Ada_Final_Name.all & " (void);"); - -- If -a has been specified use __attribute__((constructor)) for the - -- init procedure. No need to use a similar featute for the final - -- procedure as global finalization will occur when the executable - -- finishes execution and for plugins (shared stand-alone libraries that - -- can be "unloaded"), finalization should not occur automatically, - -- otherwise the main executable may not continue to work properly. + -- init procedure and __attribute__((destructor)) for the final one. if Use_Pragma_Linker_Constructor then WBI ("extern void " & Ada_Init_Name.all & @@ -3035,6 +3140,15 @@ package body Bindgen is WBI ("extern void " & Ada_Init_Name.all & " (void);"); end if; + if not Cumulative_Restrictions.Set (No_Finalization) then + if Use_Pragma_Linker_Constructor then + WBI ("extern void " & Ada_Final_Name.all & + " (void) __attribute__((destructor));"); + else + WBI ("extern void " & Ada_Final_Name.all & " (void);"); + end if; + end if; + WBI ("extern void system__standard_library__adafinal (void);"); if not No_Main_Subprogram then @@ -3099,29 +3213,15 @@ package body Bindgen is WBI (""); + -- Generate externals for elaboration entities + Gen_Elab_Externals_C; + Gen_Elab_Defs_C; if Needs_Library_Finalization then Gen_Finalize_Library_Defs_C; end if; - -- Imported variables used only when we have a runtime - - if not Suppress_Standard_Library_On_Target then - - -- Track elaboration/finalization phase - - WBI ("extern int __gnat_handler_installed;"); - WBI (""); - - -- Track feature enable/disable on VMS - - if OpenVMS_On_Target then - WBI ("extern int __gnat_features_set;"); - WBI (""); - end if; - end if; - -- Write argv/argc exit status stuff if main program case if Bind_Main_Program then @@ -3174,8 +3274,8 @@ package body Bindgen is -- (for the debugger to get initial control) is defined in this file. if Suppress_Standard_Library_On_Target then - WBI (""); WBI ("void __gnat_break_start (void) {}"); + WBI (""); end if; -- Generate the __gnat_version and __gnat_ada_main_program_name info @@ -3184,7 +3284,6 @@ package body Bindgen is -- when a C program uses 2 Ada libraries) if Bind_Main_Program then - WBI (""); WBI ("char __gnat_version[] = """ & Ver_Prefix & Gnat_Version_String & """;"); @@ -3193,12 +3292,16 @@ package body Bindgen is Set_Main_Program_Name; Set_String (""";"); Write_Statement_Buffer; + WBI (""); end if; - -- Generate the adafinal routine. In no runtime mode, this is not - -- needed, since there is no finalization to do. + -- Generate the adafinal routine unless there is no finalization to do if not Cumulative_Restrictions.Set (No_Finalization) then + if Needs_Library_Finalization then + Gen_Finalize_Library_C; + end if; + Gen_Adafinal_C; end if; diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index b915668c186..97bbf28546a 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -3463,7 +3463,7 @@ package body Checks is if Enable_Overflow_Checks and then not Is_Entity_Name (N) - and then (Lor < Lo or else Hir > Hi) + and then (Lor < Lo or else Hir > Hi) then OK := False; return; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 0bc2e386cd1..9a96e8c8d95 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -934,32 +934,34 @@ package Einfo is -- to the spec as possible. -- Elaboration_Entity (Node13) --- Present in generic and non-generic package and subprogram --- entities. This is a boolean entity associated with the unit that --- is initially set to False, and is set True when the unit is --- elaborated. This is used for two purposes. First, it is used to --- implement required access before elaboration checks (the flag --- must be true to call a subprogram at elaboration time). Second, --- it is used to guard against repeated execution of the generated --- elaboration code. +-- Present in generic and non-generic package and subprogram entities. +-- This is a counter associated with the unit that is initially set to +-- zero, is incremented when an elaboration request for the unit is +-- made, and is decremented when a finalization request for the unit +-- is made. This is used for three purposes. First, it is used to +-- implement access before elaboration checks (the counter must be +-- non-zero to call a subprogram at elaboration time). Second, it is +-- used to guard against repeated execution of the elaboration code. +-- Third, it is used to ensure that the finalization code is executed +-- only after all clients have requested it. -- --- Note that we always allocate this flag, and set this field, but +-- Note that we always allocate this counter, and set this field, but -- we do not always actually use it. It is only used if it is needed --- for access-before-elaboration use (see Elaboration_Entity_Required +-- for access before elaboration use (see Elaboration_Entity_Required -- flag) or if either the spec or the body has elaboration code. If -- neither of these two conditions holds, then the entity is still -- allocated (since we don't know early enough whether or not there -- is elaboration code), but is simply not used for any purpose. -- Elaboration_Entity_Required (Flag174) --- Present in generics and non-generic package and subprogram --- entities. Set only if Elaboration_Entity is non-Empty to indicate --- that the boolean is required to be set even if there is no other --- elaboration code. This occurs when the Elaboration_Entity flag --- is used for required access-before-elaboration checking. If the --- flag is only for preventing multiple execution of the elaboration --- code, then if there is no other elaboration code, obviously there --- is no need to set the flag. +-- Present in generic and non-generic package and subprogram entities. +-- Set only if Elaboration_Entity is non-Empty to indicate that the +-- counter is required to be non-zero even if there is no other +-- elaboration code. This occurs when the Elaboration_Entity counter +-- is used for access before elaboration checks. If the counter is +-- only used to prevent multiple execution of the elaboration code, +-- then if there is no other elaboration code, obviously there is no +-- need to set the flag. -- Enclosing_Scope (Node18) -- Present in labels. Denotes the innermost enclosing construct that diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 686bf04289a..6131b23c92c 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -1916,7 +1916,12 @@ package body Exp_Attr is begin if Present (Elaboration_Entity (Ent)) then Rewrite (N, - New_Occurrence_Of (Elaboration_Entity (Ent), Loc)); + Make_Op_Ne (Loc, + Left_Opnd => + New_Occurrence_Of (Elaboration_Entity (Ent), Loc), + Right_Opnd => + Make_Integer_Literal (Loc, Uint_0))); + Analyze_And_Resolve (N, Typ); else Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); end if; diff --git a/gcc/ada/exp_ch12.adb b/gcc/ada/exp_ch12.adb index 5ff2ee3af81..7c7f92ce38a 100644 --- a/gcc/ada/exp_ch12.adb +++ b/gcc/ada/exp_ch12.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-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- -- @@ -29,6 +29,7 @@ with Einfo; use Einfo; with Exp_Util; use Exp_Util; with Nmake; use Nmake; with Sinfo; use Sinfo; +with Snames; use Snames; with Stand; use Stand; with Tbuild; use Tbuild; @@ -59,7 +60,9 @@ package body Exp_Ch12 is Condition => Make_Op_Not (Loc, Right_Opnd => - New_Occurrence_Of (Elaboration_Entity (Ent), Loc)), + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Elaborated, + Prefix => New_Occurrence_Of (Ent, Loc))), Reason => PE_Access_Before_Elaboration)); end if; end Expand_N_Generic_Instantiation; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index cfc58e2294a..c49cf254dee 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -2897,6 +2897,7 @@ package body Exp_Ch7 is is A_Expr : Node_Id; E_Decl : Node_Id; + Result : List_Id; begin if Restriction_Active (No_Exception_Propagation) then @@ -2907,36 +2908,86 @@ package body Exp_Ch7 is pragma Assert (Present (E_Id)); pragma Assert (Present (Raised_Id)); - -- Generate: - -- Exception_Identity (Get_Current_Excep.all.all) = - -- Standard'Abort_Signal'Identity; + Result := New_List; + + -- In certain scenarios, finalization can be triggered by an abort. If + -- the finalization itself fails and raises an exception, the resulting + -- Program_Error must be supressed and replaced by an abort signal. In + -- order to detect this scenario, save the state of entry into the + -- finalization code. if Abort_Allowed then - A_Expr := - Make_Op_Eq (Loc, - Left_Opnd => - Make_Function_Call (Loc, - Name => - New_Reference_To (RTE (RE_Exception_Identity), Loc), - Parameter_Associations => New_List ( - Make_Explicit_Dereference (Loc, - Prefix => - Make_Function_Call (Loc, - Name => - Make_Explicit_Dereference (Loc, - Prefix => - New_Reference_To - (RTE (RE_Get_Current_Excep), Loc)))))), + declare + Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'E'); + + begin + -- Generate: + -- Temp : constant Exception_Occurrence_Access := + -- Get_Current_Excep.all; + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Temp_Id, + Constant_Present => True, + Object_Definition => + New_Reference_To (RTE (RE_Exception_Occurrence_Access), Loc), + Expression => + Make_Function_Call (Loc, + Name => + Make_Explicit_Dereference (Loc, + Prefix => + New_Reference_To + (RTE (RE_Get_Current_Excep), Loc))))); + + -- Generate: + -- Temp /= null + -- and then Exception_Identity (Temp.all) = + -- Standard'Abort_Signal'Identity; + + A_Expr := + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Ne (Loc, + Left_Opnd => + New_Reference_To (Temp_Id, Loc), + Right_Opnd => + Make_Null (Loc)), + + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Exception_Identity), Loc), + Parameter_Associations => New_List ( + Make_Explicit_Dereference (Loc, + Prefix => + New_Reference_To (Temp_Id, Loc)))), + + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (Stand.Abort_Signal, Loc), + Attribute_Name => Name_Identity))); + end; + + -- No abort - Right_Opnd => - Make_Attribute_Reference (Loc, - Prefix => - New_Reference_To (Stand.Abort_Signal, Loc), - Attribute_Name => Name_Identity)); else A_Expr := New_Reference_To (Standard_False, Loc); end if; + -- Generate: + -- Abort_Id : constant Boolean := ; + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Abort_Id, + Constant_Present => True, + Object_Definition => + New_Reference_To (Standard_Boolean, Loc), + Expression => A_Expr)); + -- Generate: -- E_Id : Exception_Occurrence; @@ -2947,30 +2998,20 @@ package body Exp_Ch7 is New_Reference_To (RTE (RE_Exception_Occurrence), Loc)); Set_No_Initialization (E_Decl); - return - New_List ( - - -- Abort_Id - - Make_Object_Declaration (Loc, - Defining_Identifier => Abort_Id, - Constant_Present => True, - Object_Definition => - New_Reference_To (Standard_Boolean, Loc), - Expression => A_Expr), + Append_To (Result, E_Decl); - -- E_Id - - E_Decl, + -- Generate: + -- Raised_Id : Boolean := False; - -- Raised_Id + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Raised_Id, + Object_Definition => + New_Reference_To (Standard_Boolean, Loc), + Expression => + New_Reference_To (Standard_False, Loc))); - Make_Object_Declaration (Loc, - Defining_Identifier => Raised_Id, - Object_Definition => - New_Reference_To (Standard_Boolean, Loc), - Expression => - New_Reference_To (Standard_False, Loc))); + return Result; end Build_Object_Declarations; --------------------------- @@ -4600,9 +4641,12 @@ package body Exp_Ch7 is -- controlled elements. Generate: -- declare + -- Temp : constant Exception_Occurrence_Access := + -- Get_Current_Excep.all; -- Abort : constant Boolean := - -- Exception_Identity (Get_Current_Excep.all) = - -- Standard'Abort_Signal'Identity; + -- Temp /= null + -- and then Exception_Identity (Temp_Id.all) = + -- Standard'Abort_Signal'Identity; -- -- Abort : constant Boolean := False; -- no abort @@ -4653,9 +4697,12 @@ package body Exp_Ch7 is -- exception -- when others => -- declare + -- Temp : constant Exception_Occurrence_Access := + -- Get_Current_Excep.all; -- Abort : constant Boolean := - -- Exception_Identity (Get_Current_Excep.all) = - -- Standard'Abort_Signal'Identity; + -- Temp /= null + -- and then Exception_Identity (Temp_Id.all) = + -- Standard'Abort_Signal'Identity; -- -- Abort : constant Boolean := False; -- no abort -- E : Exception_Occurence; @@ -5513,9 +5560,12 @@ package body Exp_Ch7 is -- may have discriminants and contain variant parts. Generate: -- declare + -- Temp : constant Exception_Occurrence_Access := + -- Get_Current_Excep.all; -- Abort : constant Boolean := - -- Exception_Identity (Get_Current_Excep.all) = - -- Standard'Abort_Signal'Identity; + -- Temp /= null + -- and then Exception_Identity (Temp_Id.all) = + -- Standard'Abort_Signal'Identity; -- -- Abort : constant Boolean := False; -- no abort -- E : Exception_Occurence; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 57751033c5c..cc4502ed289 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -6634,7 +6634,7 @@ package body Exp_Util is Asn := Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Ent, Loc), - Expression => New_Occurrence_Of (Standard_True, Loc)); + Expression => Make_Integer_Literal (Loc, Uint_1)); if Nkind (Parent (N)) = N_Subunit then Insert_After (Corresponding_Stub (Parent (N)), Asn); diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb index e91bf61e281..eb8593a9633 100644 --- a/gcc/ada/prj-env.adb +++ b/gcc/ada/prj-env.adb @@ -1840,6 +1840,11 @@ package body Prj.Env is Self.Path := new String'(Tmp.all & Path_Separator & Path); Free (Tmp); end if; + + if Current_Verbosity = High then + Debug_Output ("Adding directories to Project_Path: """ + & Path & '"'); + end if; end Add_Directories; -------------------- diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 6c79fdec8d1..d1b31f37329 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -930,7 +930,9 @@ package body Prj.Nmsc is Project_Path_For_Aggregate : Prj.Env.Project_Search_Path; - procedure Found_Project_File (Path : Path_Information; Rank : Natural); + procedure Found_Project_File + (Path : Path_Information; + Rank : Natural); -- Called for each project file aggregated by Project procedure Expand_Project_Files is @@ -942,7 +944,10 @@ package body Prj.Nmsc is -- Found_Project_File -- ------------------------ - procedure Found_Project_File (Path : Path_Information; Rank : Natural) is + procedure Found_Project_File + (Path : Path_Information; + Rank : Natural) + is pragma Unreferenced (Rank); begin if Path.Name /= Project.Path.Name then @@ -5041,8 +5046,8 @@ package body Prj.Nmsc is Remove_Source_Dirs : Boolean := False; procedure Add_To_Or_Remove_From_Source_Dirs - (Path : Path_Information; - Rank : Natural); + (Path : Path_Information; + Rank : Natural); -- When Removed = False, the directory Path_Id to the list of -- source_dirs if not already in the list. When Removed = True, -- removed directory Path_Id if in the list. @@ -5055,8 +5060,8 @@ package body Prj.Nmsc is --------------------------------------- procedure Add_To_Or_Remove_From_Source_Dirs - (Path : Path_Information; - Rank : Natural) + (Path : Path_Information; + Rank : Natural) is List : String_List_Id; Prev : String_List_Id; @@ -5310,9 +5315,9 @@ package body Prj.Nmsc is Remove_Source_Dirs := False; Add_To_Or_Remove_From_Source_Dirs - (Path => (Name => Project.Directory.Name, - Display_Name => Project.Directory.Display_Name), - Rank => 1); + (Path => (Name => Project.Directory.Name, + Display_Name => Project.Directory.Display_Name), + Rank => 1); else Remove_Source_Dirs := False; diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb index 366dfced32d..295ac40c06f 100644 --- a/gcc/ada/prj-proc.adb +++ b/gcc/ada/prj-proc.adb @@ -28,6 +28,7 @@ with Opt; use Opt; with Osint; use Osint; with Output; use Output; with Prj.Attr; use Prj.Attr; +with Prj.Env; with Prj.Err; use Prj.Err; with Prj.Ext; use Prj.Ext; with Prj.Nmsc; use Prj.Nmsc; @@ -1971,10 +1972,6 @@ package body Prj.Proc is & Get_Name_String (Index_Name) & ")", New_Value.Value); end if; end if; - - elsif Name = Snames.Name_Project_Path then - Debug_Output - ("Defined project path"); end if; end Process_Expression_For_Associative_Array; @@ -1987,11 +1984,10 @@ package body Prj.Proc is New_Value : Variable_Value) is Name : constant Name_Id := Name_Of (Current_Item, Node_Tree); - Var : Variable_Id := No_Variable; - Is_Attribute : constant Boolean := Kind_Of (Current_Item, Node_Tree) = N_Attribute_Declaration; + Var : Variable_Id := No_Variable; begin -- First, find the list where to find the variable or attribute. @@ -2056,6 +2052,29 @@ package body Prj.Proc is else Shared.Variable_Elements.Table (Var).Value := New_Value; end if; + + if Name = Snames.Name_Project_Path then + if In_Tree.Is_Root_Tree then + declare + Val : String_List_Id := New_Value.Values; + begin + while Val /= Nil_String loop + Prj.Env.Add_Directories + (Child_Env.Project_Path, + Get_Name_String + (Shared.String_Elements.Table (Val).Value)); + Val := Shared.String_Elements.Table (Val).Next; + end loop; + end; + + else + if Current_Verbosity = High then + Debug_Output + ("'for Project_Path' has no effect except in" + & " root aggregate"); + end if; + end if; + end if; end Process_Expression_Variable_Decl; ------------------------ diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index df71ba5155e..985022c7a17 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -504,6 +504,7 @@ package Rtsfind is RE_Exception_Message, -- Ada.Exceptions RE_Exception_Name_Simple, -- Ada.Exceptions RE_Exception_Occurrence, -- Ada.Exceptions + RE_Exception_Occurrence_Access, -- Ada.Exceptions RE_Null_Id, -- Ada.Exceptions RE_Null_Occurrence, -- Ada.Exceptions RE_Poll, -- Ada.Exceptions @@ -1682,6 +1683,7 @@ package Rtsfind is RE_Exception_Message => Ada_Exceptions, RE_Exception_Name_Simple => Ada_Exceptions, RE_Exception_Occurrence => Ada_Exceptions, + RE_Exception_Occurrence_Access => Ada_Exceptions, RE_Null_Id => Ada_Exceptions, RE_Null_Occurrence => Ada_Exceptions, RE_Poll => Ada_Exceptions, diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 7ece5832a7c..de0b5978110 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -295,9 +295,6 @@ package body Sem_Attr is procedure Check_Integer_Type; -- Verify that prefix of attribute N is an integer type - procedure Check_Library_Unit; - -- Verify that prefix of attribute N is a library unit - procedure Check_Modular_Integer_Type; -- Verify that prefix of attribute N is a modular integer type @@ -344,8 +341,8 @@ package body Sem_Attr is -- itself of the form of a library unit name. Note that this is -- quite different from Check_Program_Unit, since it only checks -- the syntactic form of the name, not the semantic identity. This - -- is because it is used with attributes (Elab_Body, Elab_Spec, and - -- UET_Address) which can refer to non-visible unit. + -- is because it is used with attributes (Elab_Body, Elab_Spec, + -- UET_Address and Elaborated) which can refer to non-visible unit. procedure Error_Attr (Msg : String; Error_Node : Node_Id); pragma No_Return (Error_Attr); @@ -1302,17 +1299,6 @@ package body Sem_Attr is end if; end Check_Integer_Type; - ------------------------ - -- Check_Library_Unit -- - ------------------------ - - procedure Check_Library_Unit is - begin - if not Is_Compilation_Unit (Entity (P)) then - Error_Attr_P ("prefix of % attribute must be library unit"); - end if; - end Check_Library_Unit; - -------------------------------- -- Check_Modular_Integer_Type -- -------------------------------- @@ -1761,7 +1747,9 @@ package body Sem_Attr is if Nkind (Nod) = N_Identifier then return; - elsif Nkind (Nod) = N_Selected_Component then + elsif Nkind (Nod) = N_Selected_Component + or else Nkind (Nod) = N_Expanded_Name + then Check_Unit_Name (Prefix (Nod)); if Nkind (Selector_Name (Nod)) = N_Identifier then @@ -3003,7 +2991,7 @@ package body Sem_Attr is when Attribute_Elaborated => Check_E0; - Check_Library_Unit; + Check_Unit_Name (P); Set_Etype (N, Standard_Boolean); ---------- diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 0a676effcfc..87f31d82e32 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -55,6 +55,7 @@ with Snames; use Snames; with Stand; use Stand; with Table; with Tbuild; use Tbuild; +with Uintp; use Uintp; with Uname; use Uname; package body Sem_Elab is @@ -2156,8 +2157,8 @@ package body Sem_Elab is Make_Object_Declaration (Loce, Defining_Identifier => Ent, Object_Definition => - New_Occurrence_Of (Standard_Boolean, Loce), - Expression => New_Occurrence_Of (Standard_False, Loce))); + New_Occurrence_Of (Standard_Integer, Loce), + Expression => Make_Integer_Literal (Loc, Uint_0))); -- Set elaboration flag at the point of the body @@ -2176,10 +2177,12 @@ package body Sem_Elab is end; end if; - -- Generate check of the elaboration Boolean + -- Generate check of the elaboration counter Insert_Elab_Check (N, - New_Occurrence_Of (Elaboration_Entity (E), Loc)); + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Elaborated, + Prefix => New_Occurrence_Of (E, Loc))); end if; -- Generate the warning @@ -2419,7 +2422,7 @@ package body Sem_Elab is not Restriction_Active (No_Entry_Calls_In_Elaboration_Code) then -- Runtime elaboration check required. Generate check of the - -- elaboration Boolean for the unit containing the entity. + -- elaboration counter for the unit containing the entity. Insert_Elab_Check (N, Make_Attribute_Reference (Loc, diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index f60aea0bcd1..7920d6d4d98 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -964,9 +964,9 @@ package body Sem_Util is Make_Object_Declaration (Loc, Defining_Identifier => Elab_Ent, Object_Definition => - New_Occurrence_Of (Standard_Boolean, Loc), + New_Occurrence_Of (Standard_Integer, Loc), Expression => - New_Occurrence_Of (Standard_False, Loc)); + Make_Integer_Literal (Loc, Uint_0)); Push_Scope (Standard_Standard); Add_Global_Declaration (Decl); diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 954a11e70e6..c8b1a1ec3cd 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -136,7 +136,7 @@ package Sem_Util is -- discriminants, and build actual subtype for it if so. procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id); - -- Given a compilation unit node N, allocate an elaboration boolean for + -- Given a compilation unit node N, allocate an elaboration counter for -- the compilation unit, and install it in the Elaboration_Entity field -- of Spec_Id, the entity for the compilation unit.