From 17752af1528d688ce71be56f0474c9bb2be7a6f5 Mon Sep 17 00:00:00 2001 From: charlet Date: Thu, 4 Aug 2011 15:18:34 +0000 Subject: 2011-08-04 Robert Dewar * sem_ch3.adb, make.adb, a-cohata.ads, sem_prag.adb, makeutl.adb, lib-xref-alfa.adb: Minor reformatting. 2011-08-04 Marc Sango * sem_ch12.adb (Analyze_Generic_Package_Declaration, Analyze_Generic_Subprogram_Declaration, Analyze_Package_Instantiation, Analyze_Subprogram_Instantiation): Check absence of generic in SPARK mode. 2011-08-04 Tristan Gingold * bindgen.adb (Gen_Adainit_C): Remove. (Gen_Adafinal_C): Ditto. (Gen_Elab_Externals_C): Ditto. (Gen_Elab_Calls_C): Ditto. (Gen_Elab_Order_C): Ditto. (Gen_Elab_Defs_C): Ditto. (Gen_Finalize_Library_C): Ditto. (Gen_Finalize_Library_Defs_C): Ditto. (Gen_Main_C): Ditto. (Gen_Output_File_C): Ditto. (Gen_Restrictions_C): Ditto. (Gen_Versions_C): Ditto. (Write_Info_Ada_C): Ditto. (Gen_Object_Files_Options): Call WBI instead of Write_Info_Ada_C (Gen_Output_File): Do not force Ada_Bind_File anymore. Always call Gen_Output_File_Ada. * gnatlink.adb (Begin_Info): Now a constant. (End_Info): Ditto. (Ada_Bind_File): Remove (Process_Args): Do not handle -A/-C. Remove not Ada_Bind_File cases. * switch-b.adb (Scan_Binder_Switches): Do not handle -C. * gnatbind.adb (Gnatbind): Remove not Ada_Bind_File cases. * opt.ads (Ada_Bind_File): Remove. 2011-08-04 Thomas Quinot * projects.texi: Document target-specific directory in default project path for gnatmake. 2011-08-04 Thomas Quinot * gnatls.adb, prj-env.adb: Add $prefix/share/gpr to default project path in all cases . git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@177395 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 48 ++ gcc/ada/a-cohata.ads | 20 +- gcc/ada/bindgen.adb | 1370 +-------------------------------------------- gcc/ada/gnatbind.adb | 20 +- gcc/ada/gnatlink.adb | 101 +--- gcc/ada/gnatls.adb | 8 + gcc/ada/lib-xref-alfa.adb | 4 +- gcc/ada/make.adb | 4 +- gcc/ada/makeutl.adb | 4 +- gcc/ada/opt.ads | 4 - gcc/ada/prj-env.adb | 14 +- gcc/ada/projects.texi | 3 +- gcc/ada/sem_ch12.adb | 8 + gcc/ada/sem_ch3.adb | 8 +- gcc/ada/sem_prag.adb | 12 +- gcc/ada/switch-b.adb | 9 - 16 files changed, 163 insertions(+), 1474 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d22593d3401..dcc0de2ec2f 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,51 @@ +2011-08-04 Robert Dewar + + * sem_ch3.adb, make.adb, a-cohata.ads, sem_prag.adb, makeutl.adb, + lib-xref-alfa.adb: Minor reformatting. + +2011-08-04 Marc Sango + + * sem_ch12.adb (Analyze_Generic_Package_Declaration, + Analyze_Generic_Subprogram_Declaration, Analyze_Package_Instantiation, + Analyze_Subprogram_Instantiation): Check absence of generic in SPARK + mode. + +2011-08-04 Tristan Gingold + + * bindgen.adb (Gen_Adainit_C): Remove. + (Gen_Adafinal_C): Ditto. + (Gen_Elab_Externals_C): Ditto. + (Gen_Elab_Calls_C): Ditto. + (Gen_Elab_Order_C): Ditto. + (Gen_Elab_Defs_C): Ditto. + (Gen_Finalize_Library_C): Ditto. + (Gen_Finalize_Library_Defs_C): Ditto. + (Gen_Main_C): Ditto. + (Gen_Output_File_C): Ditto. + (Gen_Restrictions_C): Ditto. + (Gen_Versions_C): Ditto. + (Write_Info_Ada_C): Ditto. + (Gen_Object_Files_Options): Call WBI instead of Write_Info_Ada_C + (Gen_Output_File): Do not force Ada_Bind_File anymore. + Always call Gen_Output_File_Ada. + * gnatlink.adb (Begin_Info): Now a constant. + (End_Info): Ditto. + (Ada_Bind_File): Remove + (Process_Args): Do not handle -A/-C. Remove not Ada_Bind_File cases. + * switch-b.adb (Scan_Binder_Switches): Do not handle -C. + * gnatbind.adb (Gnatbind): Remove not Ada_Bind_File cases. + * opt.ads (Ada_Bind_File): Remove. + +2011-08-04 Thomas Quinot + + * projects.texi: Document target-specific directory in default project + path for gnatmake. + +2011-08-04 Thomas Quinot + + * gnatls.adb, prj-env.adb: Add $prefix/share/gpr to default project + path in all cases . + 2011-08-04 Yannick Moy * sem_ch3.adb, sem_ch5.adb, sem_util.adb, sem_ch4.adb, sem_ch8.adb, diff --git a/gcc/ada/a-cohata.ads b/gcc/ada/a-cohata.ads index 2a6c6ab5706..1a77970a0c7 100644 --- a/gcc/ada/a-cohata.ads +++ b/gcc/ada/a-cohata.ads @@ -31,7 +31,8 @@ -- containers. package Ada.Containers.Hash_Tables is - pragma Pure; -- so this can be imported by Remote_Types packages + pragma Pure; + -- Declare Pure so this can be imported by Remote_Types packages generic type Node_Type (<>) is limited private; @@ -42,13 +43,14 @@ package Ada.Containers.Hash_Tables is type Buckets_Type is array (Hash_Type range <>) of Node_Access; type Buckets_Access is access all Buckets_Type; - for Buckets_Access'Storage_Size use 0; -- so this package can be Pure + for Buckets_Access'Storage_Size use 0; + -- Storage_Size of zero so this package can be Pure type Hash_Table_Type is tagged record Buckets : Buckets_Access; Length : Count_Type := 0; - Busy : Natural := 0; - Lock : Natural := 0; + Busy : Natural := 0; + Lock : Natural := 0; end record; end Generic_Hash_Table_Types; @@ -62,11 +64,11 @@ package Ada.Containers.Hash_Tables is (Capacity : Count_Type; Modulus : Hash_Type) is tagged record - Length : Count_Type := 0; - Busy : Natural := 0; - Lock : Natural := 0; - Free : Count_Type'Base := -1; - Nodes : Nodes_Type (1 .. Capacity) := (others => <>); + Length : Count_Type := 0; + Busy : Natural := 0; + Lock : Natural := 0; + Free : Count_Type'Base := -1; + Nodes : Nodes_Type (1 .. Capacity) := (others => <>); Buckets : Buckets_Type (1 .. Modulus) := (others => 0); end record; end Generic_Bounded_Hash_Table_Types; diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index 8c89a5095a8..279fc5567dd 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -240,54 +240,27 @@ package body Bindgen is procedure Gen_Adainit_Ada; -- Generates the Adainit procedure (Ada code case) - procedure Gen_Adainit_C; - -- Generates the Adainit procedure (C code case) - procedure Gen_Adafinal_Ada; -- Generate the Adafinal procedure (Ada code case) - 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) - procedure Gen_Elab_Calls_C; - -- Generate sequence of elaboration calls (C code case) - procedure Gen_Elab_Order_Ada; -- Generate comments showing elaboration order chosen (Ada code case) - procedure Gen_Elab_Order_C; - -- Generate comments showing elaboration order chosen (C code case) - - procedure Gen_Elab_Defs_C; - -- Generate sequence of definitions for elaboration routines (C code case) - procedure Gen_Finalize_Library_Ada; -- Generate a sequence of finalization calls to elaborated packages (Ada) - procedure Gen_Finalize_Library_C; - -- Generate a sequence of finalization calls to elaborated packages (C) - - procedure Gen_Finalize_Library_Defs_C; - -- Generate a sequence of defininitions for package finalizers (C case) - procedure Gen_CodePeer_Wrapper; -- For CodePeer, generate wrapper which calls user-defined main subprogram procedure Gen_Main_Ada; -- Generate procedure main (Ada code case) - procedure Gen_Main_C; - -- Generate main() procedure (C code case) - procedure Gen_Object_Files_Options; -- Output comments containing a list of the full names of the object -- files to be linked and the list of linker options supplied by @@ -296,21 +269,12 @@ package body Bindgen is procedure Gen_Output_File_Ada (Filename : String); -- Generate output file (Ada code case) - procedure Gen_Output_File_C (Filename : String); - -- Generate output file (C code case) - procedure Gen_Restrictions_Ada; -- Generate initialization of restrictions variable (Ada code case) - procedure Gen_Restrictions_C; - -- Generate initialization of restrictions variable (C code case) - procedure Gen_Versions_Ada; -- Output series of definitions for unit versions (Ada code case) - procedure Gen_Versions_C; - -- Output series of definitions for unit versions (C code case) - function Get_Ada_Main_Name return String; -- This function is used in the Ada main output case to compute a usable -- name for the generated main program. The normal main program name is @@ -400,10 +364,6 @@ package body Bindgen is -- up all output unit numbers nicely as required by the value, and -- by the total number of units. - procedure Write_Info_Ada_C (Ada : String; C : String; Common : String); - -- For C code case, write C & Common, for Ada case write Ada & Common - -- to current binder output file using Write_Binder_Info. - procedure Write_Statement_Buffer; -- Write out contents of statement buffer up to Last, and reset Last to 0 @@ -478,32 +438,6 @@ package body Bindgen is WBI (""); end Gen_Adafinal_Ada; - -------------------- - -- Gen_Adafinal_C -- - -------------------- - - procedure Gen_Adafinal_C is - begin - WBI ("void " & Ada_Final_Name.all & " (void) {"); - - WBI (" if (!is_elaborated)"); - WBI (" return;"); - WBI (" is_elaborated = 0;"); - - 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; - --------------------- -- Gen_Adainit_Ada -- --------------------- @@ -989,289 +923,6 @@ package body Bindgen is WBI (""); end Gen_Adainit_Ada; - ------------------- - -- Gen_Adainit_C -- - -------------------- - - procedure Gen_Adainit_C is - Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority; - Main_CPU : Int renames ALIs.Table (ALIs.First).Main_CPU; - - begin - WBI ("void " & Ada_Init_Name.all & " (void)"); - WBI ("{"); - - WBI (" if (is_elaborated)"); - WBI (" return;"); - WBI (" is_elaborated = 1;"); - - -- Standard library suppressed - - if Suppress_Standard_Library_On_Target then - - -- Case of High_Integrity_Mode mode. Set __gl_main_priority and - -- __gl_main_cpu if needed for the Ravenscar profile. - - if Main_Priority /= No_Main_Priority then - WBI (" extern int __gl_main_priority;"); - Set_String (" __gl_main_priority = "); - Set_Int (Main_Priority); - Set_Char (';'); - Write_Statement_Buffer; - end if; - - if Main_CPU /= No_Main_CPU then - WBI (" extern int __gl_main_cpu;"); - Set_String (" __gl_main_cpu = "); - Set_Int (Main_CPU); - Set_Char (';'); - Write_Statement_Buffer; - end if; - - -- Normal case (standard library not suppressed) - - else - -- Generate definition for interrupt states string - - Set_String (" static const char *local_interrupt_states = """); - - for J in 0 .. IS_Pragma_Settings.Last loop - Set_Char (IS_Pragma_Settings.Table (J)); - end loop; - - Set_String (""";"); - Write_Statement_Buffer; - - -- Generate definition for priority specific dispatching string - - Set_String - (" static const char *local_priority_specific_dispatching = """); - - for J in 0 .. PSD_Pragma_Settings.Last loop - Set_Char (PSD_Pragma_Settings.Table (J)); - end loop; - - Set_String (""";"); - Write_Statement_Buffer; - - -- Generate declaration for secondary stack default if needed - - if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then - WBI (" extern int system__secondary_stack__" & - "default_secondary_stack_size;"); - end if; - - WBI (""); - - -- Code for normal case (standard library not suppressed) - - -- We call the routine from inside adainit() because this works for - -- both programs with and without binder generated "main" functions. - - WBI (" extern int __gl_main_priority;"); - Set_String (" __gl_main_priority = "); - Set_Int (Main_Priority); - Set_Char (';'); - Write_Statement_Buffer; - - WBI (" extern int __gl_time_slice_val;"); - Set_String (" __gl_time_slice_val = "); - - if Task_Dispatching_Policy = 'F' - and then ALIs.Table (ALIs.First).Time_Slice_Value = -1 - then - Set_Int (0); - else - Set_Int (ALIs.Table (ALIs.First).Time_Slice_Value); - end if; - - Set_Char (';'); - Write_Statement_Buffer; - - WBI (" extern char __gl_wc_encoding;"); - Set_String (" __gl_wc_encoding = '"); - Set_Char (Get_WC_Encoding); - - Set_String ("';"); - Write_Statement_Buffer; - - WBI (" extern char __gl_locking_policy;"); - Set_String (" __gl_locking_policy = '"); - Set_Char (Locking_Policy_Specified); - Set_String ("';"); - Write_Statement_Buffer; - - WBI (" extern char __gl_queuing_policy;"); - Set_String (" __gl_queuing_policy = '"); - Set_Char (Queuing_Policy_Specified); - Set_String ("';"); - Write_Statement_Buffer; - - WBI (" extern char __gl_task_dispatching_policy;"); - Set_String (" __gl_task_dispatching_policy = '"); - Set_Char (Task_Dispatching_Policy_Specified); - Set_String ("';"); - Write_Statement_Buffer; - - WBI (" extern int __gl_main_cpu;"); - Set_String (" __gl_main_cpu = "); - Set_Int (Main_CPU); - Set_Char (';'); - Write_Statement_Buffer; - - Gen_Restrictions_C; - - WBI (" extern const void *__gl_interrupt_states;"); - WBI (" __gl_interrupt_states = local_interrupt_states;"); - - WBI (" extern int __gl_num_interrupt_states;"); - Set_String (" __gl_num_interrupt_states = "); - Set_Int (IS_Pragma_Settings.Last + 1); - Set_String (";"); - Write_Statement_Buffer; - - WBI (" extern const void *__gl_priority_specific_dispatching;"); - WBI (" __gl_priority_specific_dispatching =" & - " local_priority_specific_dispatching;"); - - WBI (" extern int __gl_num_specific_dispatching;"); - Set_String (" __gl_num_specific_dispatching = "); - Set_Int (PSD_Pragma_Settings.Last + 1); - Set_String (";"); - Write_Statement_Buffer; - - WBI (" extern int __gl_unreserve_all_interrupts;"); - Set_String (" __gl_unreserve_all_interrupts = "); - Set_Int (Boolean'Pos (Unreserve_All_Interrupts_Specified)); - Set_String (";"); - Write_Statement_Buffer; - - if Exception_Tracebacks then - WBI (" extern int __gl_exception_tracebacks;"); - WBI (" __gl_exception_tracebacks = 1;"); - end if; - - WBI (" extern int __gl_zero_cost_exceptions;"); - Set_String (" __gl_zero_cost_exceptions = "); - Set_Int (Boolean'Pos (Zero_Cost_Exceptions_Specified)); - Set_String (";"); - Write_Statement_Buffer; - - WBI (" extern int __gl_detect_blocking;"); - Set_String (" __gl_detect_blocking = "); - - if Detect_Blocking then - Set_Int (1); - else - Set_Int (0); - end if; - - Set_String (";"); - Write_Statement_Buffer; - - WBI (" extern int __gl_default_stack_size;"); - Set_String (" __gl_default_stack_size = "); - Set_Int (Default_Stack_Size); - Set_String (";"); - Write_Statement_Buffer; - - WBI (" extern int __gl_leap_seconds_support;"); - Set_String (" __gl_leap_seconds_support = "); - - if Leap_Seconds_Support then - Set_Int (1); - else - Set_Int (0); - end if; - - 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 (" __gnat_install_handler ();"); - - -- 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 (" __gnat_set_features ();"); - end if; - end if; - - -- Initialize stack limit for the environment task if the stack - -- check method is stack limit and stack check is enabled. - - if Stack_Check_Limits_On_Target - and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set) - then - WBI (""); - WBI (" __gnat_initialize_stack_limit ();"); - end if; - - -- Generate call to set Initialize_Scalar values if needed - - if Initialize_Scalars_Used then - WBI (""); - Set_String (" system__scalar_values__initialize('"); - Set_Char (Initialize_Scalars_Mode1); - Set_String ("', '"); - Set_Char (Initialize_Scalars_Mode2); - Set_String ("');"); - Write_Statement_Buffer; - end if; - - -- Generate assignment of default secondary stack size if set - - if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then - WBI (""); - Set_String (" system__secondary_stack__"); - Set_String ("default_secondary_stack_size = "); - Set_Int (Opt.Default_Sec_Stack_Size); - Set_Char (';'); - 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 (""); - Gen_Elab_Calls_C; - WBI ("}"); - WBI (""); - end Gen_Adainit_C; - ---------------------------- -- Gen_Elab_Externals_Ada -- ---------------------------- @@ -1361,45 +1012,6 @@ package body Bindgen is 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 short 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 -- ------------------------ @@ -1541,142 +1153,13 @@ package body Bindgen is end loop; end Gen_Elab_Calls_Ada; - ---------------------- - -- Gen_Elab_Calls_C -- - ---------------------- + ------------------------ + -- Gen_Elab_Order_Ada -- + ------------------------ - procedure Gen_Elab_Calls_C is + procedure Gen_Elab_Order_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); - - Unum_Spec : Unit_Id; - -- This is the unit number of the spec that corresponds to - -- this entry. It is the same as Unum except when the body - -- and spec are different and we are currently processing - -- the body, in which case it is the spec (Unum + 1). - - begin - if U.Utype = Is_Body then - Unum_Spec := Unum + 1; - else - Unum_Spec := Unum; - end if; - - -- Nothing to do if predefined unit in no run time mode - - 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. In that case, this is - -- where we increment the elaboration entity. - - if U.Utype = Is_Body - and then Units.Table (Unum_Spec).Set_Elab_Entity - then - Get_Name_String (U.Uname); - - Set_String (" "); - Set_Unit_Name; - 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) - -- uname__elab[s|b] (); - -- uname_E++; - - -- Otherwise, elaboration routines are called unconditionally: - - -- uname__elab[s|b] (); - -- uname_E++; - - -- 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 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 (" "); - Set_Unit_Name; - Set_String ("___elab"); - Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body - Set_String (" ();"); - Write_Statement_Buffer; - - if U.Utype /= Is_Spec then - Set_String (" "); - Set_Unit_Name; - Set_String ("_E++;"); - Write_Statement_Buffer; - end if; - end if; - end; - end loop; - end Gen_Elab_Calls_C; - - ---------------------- - -- Gen_Elab_Defs_C -- - ---------------------- - - procedure Gen_Elab_Defs_C is - begin - WBI ("/* BEGIN ELABORATION DEFINITIONS */"); - - for E in Elab_Order.First .. Elab_Order.Last loop - - -- Generate declaration of elaboration procedure if elaboration - -- needed. Note that passive units are always excluded. - - if not Units.Table (Elab_Order.Table (E)).No_Elab then - Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname); - Set_String ("extern void "); - Set_Unit_Name; - Set_String ("___elab"); - Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body - Set_String (" (void);"); - Write_Statement_Buffer; - end if; - end loop; - - WBI ("/* END ELABORATION DEFINITIONS */"); - WBI (""); - end Gen_Elab_Defs_C; - - ------------------------ - -- Gen_Elab_Order_Ada -- - ------------------------ - - procedure Gen_Elab_Order_Ada is - begin - WBI (" -- BEGIN ELABORATION ORDER"); + WBI (" -- BEGIN ELABORATION ORDER"); for J in Elab_Order.First .. Elab_Order.Last loop Set_String (" -- "); @@ -1689,24 +1172,6 @@ package body Bindgen is WBI (""); end Gen_Elab_Order_Ada; - ---------------------- - -- Gen_Elab_Order_C -- - ---------------------- - - procedure Gen_Elab_Order_C is - begin - WBI ("/* BEGIN ELABORATION ORDER"); - - for J in Elab_Order.First .. Elab_Order.Last loop - Get_Name_String (Units.Table (Elab_Order.Table (J)).Uname); - Set_Name_Buffer; - Write_Statement_Buffer; - end loop; - - WBI (" END ELABORATION ORDER */"); - WBI (""); - end Gen_Elab_Order_C; - ------------------------------ -- Gen_Finalize_Library_Ada -- ------------------------------ @@ -1979,194 +1444,6 @@ package body Bindgen is end if; end Gen_Finalize_Library_Ada; - ---------------------------- - -- Gen_Finalize_Library_C -- - ---------------------------- - - procedure Gen_Finalize_Library_C is - U : Unit_Record; - Uspec : Unit_Record; - Unum : Unit_Id; - - procedure Gen_Header; - -- Generate the header of the finalization routine - - procedure Gen_Header is - begin - WBI ("static void finalize_library(void) {"); - end Gen_Header; - - begin - for E in reverse Elab_Order.First .. Elab_Order.Last loop - Unum := Elab_Order.Table (E); - U := Units.Table (Unum); - - -- Dealing with package bodies is a little complicated. In such - -- cases we must retrieve the package spec since it contains the - -- spec of the body finalizer. - - if U.Utype = Is_Body then - Unum := Unum + 1; - Uspec := Units.Table (Unum); - else - Uspec := U; - end if; - - Get_Name_String (Uspec.Uname); - - -- We are only interested in non-generic packages - - if U.Unit_Kind /= 'p' or else U.Is_Generic then - null; - - -- .. that are not interfaces to a stand alone library - - elsif U.SAL_Interface then - null; - - -- Case of no finalization - - elsif not U.Has_Finalizer 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 a finalizer. In that case, this is where we decrement - -- the elaboration entity. - - if U.Utype = Is_Body and then Uspec.Has_Finalizer then - if not Lib_Final_Built then - Gen_Header; - Lib_Final_Built := True; - end if; - - Set_String (" "); - Set_Unit_Name; - Set_String ("_E--;"); - Write_Statement_Buffer; - end if; - - else - if not Lib_Final_Built then - Gen_Header; - Lib_Final_Built := True; - end if; - - -- If binding a library or if there is a non-Ada main subprogram - -- then we generate: - - -- uname_E--; - -- if (uname_E == 0) - -- uname__finalize_[spec|body] (); - - -- Otherwise, finalization routines are called unconditionally: - - -- uname_E--; - -- uname__finalize_[spec|body] (); - - -- The uname_E decrement is skipped if this is a separate spec, - -- since it will be done when we process the body. - - if U.Utype /= Is_Spec then - Set_String (" "); - Set_Unit_Name; - Set_String ("_E--;"); - Write_Statement_Buffer; - end if; - - 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_"); - - -- Package spec processing - - if U.Utype = Is_Spec - or else U.Utype = Is_Spec_Only - then - Set_String ("spec"); - - -- Package body processing - - else - Set_String ("body"); - end if; - - Set_String (" ();"); - - Write_Statement_Buffer; - end if; - end loop; - - if Lib_Final_Built then - WBI ("}"); - WBI (""); - end if; - end Gen_Finalize_Library_C; - - --------------------------------- - -- Gen_Finalize_Library_Defs_C -- - --------------------------------- - - procedure Gen_Finalize_Library_Defs_C is - U : Unit_Record; - Uspec : Unit_Record; - Unum : Unit_Id; - - begin - WBI ("/* BEGIN FINALIZE DEFINITIONS */"); - - for E in reverse Elab_Order.First .. Elab_Order.Last loop - Unum := Elab_Order.Table (E); - U := Units.Table (Unum); - - -- We are only interested in non-generic packages - - if U.Unit_Kind = 'p' - and then U.Has_Finalizer - and then not U.Is_Generic - and then not U.No_Elab - then - -- Dealing with package bodies is a little complicated. In such - -- cases we must retrieve the package spec since it contains the - -- spec of the body finalizer. - - if U.Utype = Is_Body then - Unum := Unum + 1; - Uspec := Units.Table (Unum); - else - Uspec := U; - end if; - - Set_String ("extern void "); - Get_Name_String (Uspec.Uname); - Set_Unit_Name; - Set_String ("__finalize_"); - - if U.Utype = Is_Spec - or else U.Utype = Is_Spec_Only - then - Set_String ("spec"); - else - Set_String ("body"); - end if; - - Set_String (" (void);"); - Write_Statement_Buffer; - end if; - end loop; - - WBI ("/* END FINALIZE DEFINITIONS */"); - WBI (""); - end Gen_Finalize_Library_Defs_C; - -------------------------- -- Gen_CodePeer_Wrapper -- -------------------------- @@ -2428,226 +1705,31 @@ package body Bindgen is if Dynamic_Stack_Measurement then WBI (" Output_Results;"); - end if; - - -- Finalize is only called if we have a run time - - if not Cumulative_Restrictions.Set (No_Finalization) - and then not CodePeer_Mode - then - WBI (" Finalize;"); - end if; - - -- Return result - - if Exit_Status_Supported_On_Target then - if No_Main_Subprogram - or else ALIs.Table (ALIs.First).Main_Program = Proc - then - WBI (" return (gnat_exit_status);"); - else - WBI (" return (Result);"); - end if; - end if; - - WBI (" end;"); - WBI (""); - end Gen_Main_Ada; - - ---------------- - -- Gen_Main_C -- - ---------------- - - procedure Gen_Main_C is - begin - if Exit_Status_Supported_On_Target then - WBI ("#include "); - WBI (""); - Set_String ("int "); - else - Set_String ("void "); - end if; - - Set_String (Get_Main_Name); - - -- Generate command line args in prototype if present on target - - if Command_Line_Args_On_Target then - Write_Statement_Buffer (" (int argc, char **argv, char **envp)"); - - -- Case of no command line arguments on target - - else - Write_Statement_Buffer (" (void)"); - end if; - - WBI ("{"); - - -- Generate a reference to __gnat_ada_main_program_name. This symbol - -- is not referenced elsewhere in the generated program, but is - -- needed by the debugger (that's why it is generated in the first - -- place). The reference stops Ada_Main_Program_Name from being - -- optimized away by smart linkers, such as the AiX linker. - - -- Because this variable is unused, we declare this variable as - -- volatile in order to tell the compiler to preserve it at any - -- level of optimization. - - if Bind_Main_Program then - WBI (" char * volatile ensure_reference " & - "__attribute__ ((__unused__)) = " & - "__gnat_ada_main_program_name;"); - WBI (""); - - if not Suppress_Standard_Library_On_Target - and then not No_Main_Subprogram - then - WBI (" int SEH [2];"); - WBI (""); - end if; - end if; - - -- If main program is a function, generate result variable - - if ALIs.Table (ALIs.First).Main_Program = Func then - WBI (" int result;"); - end if; - - -- Set command line argument values from parameters if command line - -- arguments are present on target - - if Command_Line_Args_On_Target then - WBI (" gnat_argc = argc;"); - WBI (" gnat_argv = argv;"); - WBI (" gnat_envp = envp;"); - WBI (""); - - -- If configurable run-time, then nothing to do, since in this case - -- the gnat_argc/argv/envp variables are entirely suppressed. - - elsif Configurable_Run_Time_On_Target then - null; - - -- if no command line arguments on target, set dummy values - - else - WBI (" gnat_argc = 0;"); - WBI (" gnat_argv = 0;"); - WBI (" gnat_envp = 0;"); - end if; - - if Opt.Default_Exit_Status /= 0 - and then Bind_Main_Program - and then not Configurable_Run_Time_Mode - then - Set_String (" __gnat_set_exit_status ("); - Set_Int (Opt.Default_Exit_Status); - Set_String (");"); - Write_Statement_Buffer; - end if; - - -- Initializes dynamic stack measurement if needed - - if Dynamic_Stack_Measurement then - Set_String (" __gnat_stack_usage_initialize ("); - Set_Int (Dynamic_Stack_Measurement_Array_Size); - Set_String (");"); - Write_Statement_Buffer; - end if; - - -- The __gnat_initialize routine is used only if we have a run-time - - if not Suppress_Standard_Library_On_Target then - if not No_Main_Subprogram and then Bind_Main_Program then - WBI (" __gnat_initialize ((void *)SEH);"); - else - WBI (" __gnat_initialize ((void *)0);"); - end if; - end if; - - WBI (" " & Ada_Init_Name.all & " ();"); - - if not No_Main_Subprogram then - - -- Output main program name - - Get_Name_String (Units.Table (First_Unit_Entry).Uname); - - -- Main program is procedure case - - if ALIs.Table (ALIs.First).Main_Program = Proc then - Set_String (" "); - Set_Main_Program_Name; - Set_String (" ();"); - Write_Statement_Buffer; - - -- Main program is function case - - else -- ALIs.Table (ALIs_First).Main_Program = Func - Set_String (" result = "); - Set_Main_Program_Name; - Set_String (" ();"); - Write_Statement_Buffer; - end if; - - end if; - - -- Call adafinal if finalization active - - if not Cumulative_Restrictions.Set (No_Finalization) then - WBI (" " & Ada_Final_Name.all & " ();"); - end if; - - -- Outputs the dynamic stack measurement if needed - - if Dynamic_Stack_Measurement then - WBI (" __gnat_stack_usage_output_results ();"); - end if; - - -- The finalize routine is used only if we have a run-time - - if not Suppress_Standard_Library_On_Target then - WBI (" __gnat_finalize ();"); - end if; - - -- Case of main program is a function, so the value it returns - -- is the exit status in this case. - - if ALIs.Table (ALIs.First).Main_Program = Func then - if Exit_Status_Supported_On_Target then - - -- VMS must use Posix exit routine in order to get the effect - -- of a Unix compatible setting of the program exit status. - -- For all other systems, we use the standard exit routine. - - if OpenVMS_On_Target then - WBI (" decc$__posix_exit (result);"); - else - WBI (" exit (result);"); - end if; - end if; + end if; - -- Case of main program is a procedure, in which case the exit - -- status is whatever was set by a Set_Exit call most recently + -- Finalize is only called if we have a run time - else - if Exit_Status_Supported_On_Target then + if not Cumulative_Restrictions.Set (No_Finalization) + and then not CodePeer_Mode + then + WBI (" Finalize;"); + end if; - -- VMS must use Posix exit routine in order to get the effect - -- of a Unix compatible setting of the program exit status. - -- For all other systems, we use the standard exit routine. + -- Return result - if OpenVMS_On_Target then - WBI (" decc$__posix_exit (gnat_exit_status);"); - else - WBI (" exit (gnat_exit_status);"); - end if; + if Exit_Status_Supported_On_Target then + if No_Main_Subprogram + or else ALIs.Table (ALIs.First).Main_Program = Proc + then + WBI (" return (gnat_exit_status);"); + else + WBI (" return (Result);"); end if; end if; - WBI ("}"); + WBI (" end;"); WBI (""); - end Gen_Main_C; + end Gen_Main_Ada; ------------------------------ -- Gen_Object_Files_Options -- @@ -2706,8 +1788,7 @@ package body Bindgen is Write_Str (Name_Buffer (Start .. Stop - 1)); Write_Eol; end if; - Write_Info_Ada_C - (" -- ", "", Name_Buffer (Start .. Stop - 1)); + WBI (" -- " & Name_Buffer (Start .. Stop - 1)); end if; Start := Stop + 1; @@ -2717,7 +1798,7 @@ package body Bindgen is -- Start of processing for Gen_Object_Files_Options begin - Write_Info_Ada_C ("-- ", "/* ", " BEGIN Object file/option list"); + WBI ("-- BEGIN Object file/option list"); if Object_List_Filename /= null then Set_List_File (Object_List_Filename.all); @@ -2742,7 +1823,7 @@ package body Bindgen is or else System.OS_Lib.Is_Regular_File (Name_Buffer (1 .. Name_Len)) then - Write_Info_Ada_C (" -- ", "", Name_Buffer (1 .. Name_Len)); + WBI (" -- " & Name_Buffer (1 .. Name_Len)); if Output_Object_List then Write_Str (Name_Buffer (1 .. Name_Len)); @@ -2857,7 +1938,7 @@ package body Bindgen is -- Write directly to avoid -K output (why???) - Write_Info_Ada_C (" -- ", "", Name_Buffer (1 .. Name_Len)); + WBI (" -- " & Name_Buffer (1 .. Name_Len)); if With_DECGNAT then Name_Len := 0; @@ -2905,11 +1986,7 @@ package body Bindgen is Write_Eol; end if; - if Ada_Bind_File then - WBI ("-- END Object file/option list "); - else - WBI (" END Object file/option list */"); - end if; + WBI ("-- END Object file/option list "); end Gen_Object_Files_Options; --------------------- @@ -2926,16 +2003,10 @@ package body Bindgen is Set_PSD_Pragma_Table; - -- Override Ada_Bind_File and Bind_Main_Program for VMs since JGNAT only - -- supports Ada code, and the main program is already generated by the - -- compiler. - - if VM_Target /= No_VM then - Ada_Bind_File := True; + -- For JGNAT the main program is already generated by the compiler - if VM_Target = JVM_Target then - Bind_Main_Program := False; - end if; + if VM_Target = JVM_Target then + Bind_Main_Program := False; end if; -- Override time slice value if -T switch is set @@ -2958,11 +2029,7 @@ package body Bindgen is Check_System_Restrictions_Used; - if Ada_Bind_File then - Gen_Output_File_Ada (Filename); - else - Gen_Output_File_C (Filename); - end if; + Gen_Output_File_Ada (Filename); end Gen_Output_File; ------------------------- @@ -3335,217 +2402,6 @@ package body Bindgen is Close_Binder_Output; end Gen_Output_File_Ada; - ----------------------- - -- Gen_Output_File_C -- - ----------------------- - - procedure Gen_Output_File_C (Filename : String) is - - Needs_Library_Finalization : constant Boolean := - not Configurable_Run_Time_On_Target - and then Has_Finalizer; - -- ??? seems like we repeat this cantation often, should it be global? - - Bfile : Name_Id; - pragma Warnings (Off, Bfile); - -- Name of generated bind file (not referenced) - - begin - Create_Binder_Output (Filename, 'c', Bfile); - - Resolve_Binder_Options; - - -- If -a has been specified use __attribute__((constructor)) for the - -- init procedure and __attribute__((destructor)) for the final one. - - if Use_Pragma_Linker_Constructor then - WBI ("extern void " & Ada_Init_Name.all & - " (void) __attribute__((constructor));"); - else - 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 - Set_String ("extern "); - - if Exit_Status_Supported_On_Target then - Set_String ("int"); - else - Set_String ("void"); - end if; - - Set_String (" main "); - - if Command_Line_Args_On_Target then - Write_Statement_Buffer ("(int, char **, char **);"); - else - Write_Statement_Buffer ("(void);"); - end if; - - if OpenVMS_On_Target then - WBI ("extern void decc$__posix_exit (int);"); - else - WBI ("extern void exit (int);"); - end if; - - Set_String ("extern "); - - if ALIs.Table (ALIs.First).Main_Program = Proc then - Set_String ("void "); - else - Set_String ("int "); - end if; - - Get_Name_String (Units.Table (First_Unit_Entry).Uname); - Set_Main_Program_Name; - Set_String (" (void);"); - Write_Statement_Buffer; - end if; - - if not Suppress_Standard_Library_On_Target then - WBI ("extern void __gnat_initialize (void *);"); - WBI ("extern void __gnat_finalize (void);"); - WBI ("extern void __gnat_install_handler (void);"); - end if; - - if Dynamic_Stack_Measurement then - WBI (""); - WBI ("extern void __gnat_stack_usage_output_results (void);"); - WBI ("extern void __gnat_stack_usage_initialize (int size);"); - end if; - - -- Initialize stack limit for the environment task if the stack check - -- method is stack limit and stack check is enabled. - - if Stack_Check_Limits_On_Target - and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set) - then - WBI (""); - WBI ("extern void __gnat_initialize_stack_limit (void);"); - end if; - - 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; - - -- Write argv/argc exit status stuff if main program case - - if Bind_Main_Program then - - -- First deal with argc/argv/envp. In the normal case they are in the - -- run-time library. - - if not Configurable_Run_Time_On_Target then - WBI ("extern int gnat_argc;"); - WBI ("extern char **gnat_argv;"); - WBI ("extern char **gnat_envp;"); - - -- If configurable run time and no command line args, then the - -- generation of these variables is entirely suppressed. - - elsif not Command_Line_Args_On_Target then - null; - - -- Otherwise, in the configurable run-time case they are right in the - -- binder file. - - else - WBI ("int gnat_argc;"); - WBI ("char **gnat_argv;"); - WBI ("char **gnat_envp;"); - end if; - - -- Similarly deal with exit status - - if not Configurable_Run_Time_On_Target then - WBI ("extern int gnat_exit_status;"); - - -- If configurable run time and no exit status on target, then the - -- generation of this variables is entirely suppressed. - - elsif not Exit_Status_Supported_On_Target then - null; - - -- Otherwise, in the configurable run-time case this variable is - -- right in the binder file, and initialized to zero there. - - else - WBI ("int gnat_exit_status = 0;"); - end if; - - WBI (""); - end if; - - -- Generate the __gnat_version and __gnat_ada_main_program_name info - -- only for the main program. Otherwise, it can lead under some - -- circumstances to a symbol duplication during the link (for instance - -- when a C program uses 2 Ada libraries) - - if Bind_Main_Program then - WBI ("char __gnat_version[] = """ & Ver_Prefix & - Gnat_Version_String & """;"); - - Set_String ("char __gnat_ada_main_program_name[] = """); - Get_Name_String (Units.Table (First_Unit_Entry).Uname); - Set_Main_Program_Name; - Set_String (""";"); - Write_Statement_Buffer; - WBI (""); - end if; - - -- The B.1 (39) implementation advice says that the adainit/adafinal - -- routines should be idempotent. Generate a flag to ensure that. - - WBI ("static char is_elaborated = 0;"); - WBI (""); - - -- 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; - - Gen_Adainit_C; - - -- Main is only present for Ada main case - - if Bind_Main_Program then - Gen_Main_C; - end if; - - -- Generate versions, elaboration order, list of object files - - Gen_Versions_C; - Gen_Elab_Order_C; - Gen_Object_Files_Options; - - -- C binder output is complete - - Close_Binder_Output; - end Gen_Output_File_C; - -------------------------- -- Gen_Restrictions_Ada -- -------------------------- @@ -3628,96 +2484,6 @@ package body Bindgen is Write_Statement_Buffer; end Gen_Restrictions_Ada; - ------------------------ - -- Gen_Restrictions_C -- - ------------------------ - - procedure Gen_Restrictions_C is - begin - if Suppress_Standard_Library_On_Target - or not System_Restrictions_Used - then - return; - end if; - - WBI (" typedef struct {"); - Set_String (" char set ["); - Set_Int (Cumulative_Restrictions.Set'Length); - Set_String ("];"); - Write_Statement_Buffer; - - Set_String (" int value ["); - Set_Int (Cumulative_Restrictions.Value'Length); - Set_String ("];"); - Write_Statement_Buffer; - - Set_String (" char violated ["); - Set_Int (Cumulative_Restrictions.Violated'Length); - Set_String ("];"); - Write_Statement_Buffer; - - Set_String (" int count ["); - Set_Int (Cumulative_Restrictions.Count'Length); - Set_String ("];"); - Write_Statement_Buffer; - - Set_String (" char unknown ["); - Set_Int (Cumulative_Restrictions.Unknown'Length); - Set_String ("];"); - Write_Statement_Buffer; - WBI (" } restrictions;"); - WBI (" extern restrictions " & - "system__restrictions__run_time_restrictions;"); - WBI (" restrictions r = {"); - Set_String (" {"); - - for J in Cumulative_Restrictions.Set'Range loop - Set_Int (Boolean'Pos (Cumulative_Restrictions.Set (J))); - Set_String (", "); - end loop; - - Set_String_Replace ("},"); - Write_Statement_Buffer; - Set_String (" {"); - - for J in Cumulative_Restrictions.Value'Range loop - Set_Int (Int (Cumulative_Restrictions.Value (J))); - Set_String (", "); - end loop; - - Set_String_Replace ("},"); - Write_Statement_Buffer; - Set_String (" {"); - - for J in Cumulative_Restrictions.Violated'Range loop - Set_Int (Boolean'Pos (Cumulative_Restrictions.Violated (J))); - Set_String (", "); - end loop; - - Set_String_Replace ("},"); - Write_Statement_Buffer; - Set_String (" {"); - - for J in Cumulative_Restrictions.Count'Range loop - Set_Int (Int (Cumulative_Restrictions.Count (J))); - Set_String (", "); - end loop; - - Set_String_Replace ("},"); - Write_Statement_Buffer; - Set_String (" {"); - - for J in Cumulative_Restrictions.Unknown'Range loop - Set_Int (Boolean'Pos (Cumulative_Restrictions.Unknown (J))); - Set_String (", "); - end loop; - - Set_String_Replace ("}}"); - Set_String (";"); - Write_Statement_Buffer; - WBI (" system__restrictions__run_time_restrictions = r;"); - end Gen_Restrictions_C; - ---------------------- -- Gen_Versions_Ada -- ---------------------- @@ -3795,54 +2561,6 @@ package body Bindgen is end loop; end Gen_Versions_Ada; - -------------------- - -- Gen_Versions_C -- - -------------------- - - -- This routine generates a line of the form: - - -- unsigned unam = 0xhhhhhhhh; - - -- for each unit, where unam is the unit name suffixed by either B or S for - -- body or spec, with dots replaced by double underscores. - - procedure Gen_Versions_C is - begin - for U in Units.First .. Units.Last loop - if not Units.Table (U).SAL_Interface - and then - (not Bind_For_Library or else Units.Table (U).Directly_Scanned) - then - Set_String ("unsigned "); - - Get_Name_String (Units.Table (U).Uname); - - for K in 1 .. Name_Len loop - if Name_Buffer (K) = '.' then - Set_String ("__"); - - elsif Name_Buffer (K) = '%' then - exit; - - else - Set_Char (Name_Buffer (K)); - end if; - end loop; - - if Name_Buffer (Name_Len) = 's' then - Set_Char ('S'); - else - Set_Char ('B'); - end if; - - Set_String (" = 0x"); - Set_String (Units.Table (U).Version); - Set_Char (';'); - Write_Statement_Buffer; - end if; - end loop; - end Gen_Versions_C; - ------------------------ -- Get_Main_Unit_Name -- ------------------------ @@ -4291,32 +3009,6 @@ package body Bindgen is Set_Int (Unum); end Set_Unit_Number; - ---------------------- - -- Write_Info_Ada_C -- - ---------------------- - - procedure Write_Info_Ada_C (Ada : String; C : String; Common : String) is - begin - if Ada_Bind_File then - declare - S : String (1 .. Ada'Length + Common'Length); - begin - S (1 .. Ada'Length) := Ada; - S (Ada'Length + 1 .. S'Length) := Common; - WBI (S); - end; - - else - declare - S : String (1 .. C'Length + Common'Length); - begin - S (1 .. C'Length) := C; - S (C'Length + 1 .. S'Length) := Common; - WBI (S); - end; - end if; - end Write_Info_Ada_C; - ---------------------------- -- Write_Statement_Buffer -- ---------------------------- diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb index 2c83bf2262d..18eb36e01ec 100644 --- a/gcc/ada/gnatbind.adb +++ b/gcc/ada/gnatbind.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- 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- -- @@ -568,20 +568,12 @@ begin Last : constant Natural := Output_File_Name'Last; begin - if Ada_Bind_File then - if Length <= 4 - or else Output_File_Name (Last - 3 .. Last) /= ".adb" - then - Fail ("output file name should have .adb extension"); - end if; - - else - if Length <= 2 - or else Output_File_Name (Last - 1 .. Last) /= ".c" - then - Fail ("output file name should have .c extension"); - end if; + if Length <= 4 + or else Output_File_Name (Last - 3 .. Last) /= ".adb" + then + Fail ("output file name should have .adb extension"); end if; + end Check_Extensions; end if; diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index 946c7b54177..7e7a10bd9ab 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -141,9 +141,8 @@ procedure Gnatlink is Read_Mode : constant String := "r" & ASCII.NUL; - Begin_Info : String := "-- BEGIN Object file/option list"; - End_Info : String := "-- END Object file/option list "; - -- Note: above lines are modified in C mode, see option processing + Begin_Info : constant String := "-- BEGIN Object file/option list"; + End_Info : constant String := "-- END Object file/option list "; Gcc_Path : String_Access; Linker_Path : String_Access; @@ -163,9 +162,6 @@ procedure Gnatlink is Verbose_Mode : Boolean := False; Very_Verbose_Mode : Boolean := False; - Ada_Bind_File : Boolean := True; - -- Set to True if bind file is generated in Ada - Standard_Gcc : Boolean := True; Compile_Bind_File : Boolean := True; @@ -413,11 +409,6 @@ procedure Gnatlink is elsif Arg'Length = 2 then case Arg (2) is - when 'A' => - Ada_Bind_File := True; - Begin_Info := "-- BEGIN Object file/option list"; - End_Info := "-- END Object file/option list "; - when 'b' => Linker_Options.Increment_Last; Linker_Options.Table (Linker_Options.Last) := @@ -448,11 +439,6 @@ procedure Gnatlink is end Get_Machine_Name; - when 'C' => - Ada_Bind_File := False; - Begin_Info := "/* BEGIN Object file/option list"; - End_Info := " END Object file/option list */"; - when 'f' => if Object_List_File_Supported then Object_List_File_Required := True; @@ -663,13 +649,11 @@ procedure Gnatlink is Next_Arg := Next_Arg + 1; end loop; - -- If Ada bind file, then compile it with warnings suppressed, because + -- Compile the bind file with warnings suppressed, because -- otherwise the with of the main program may cause junk warnings. - if Ada_Bind_File then - Binder_Options.Increment_Last; - Binder_Options.Table (Binder_Options.Last) := new String'("-gnatws"); - end if; + Binder_Options.Increment_Last; + Binder_Options.Table (Binder_Options.Last) := new String'("-gnatws"); -- If we did not get an ali file at all, and we had at least one -- linker option, then assume that was the intended ali file after @@ -937,11 +921,8 @@ procedure Gnatlink is exit when Next_Line (Nfirst .. Nlast) = End_Info; - if Ada_Bind_File then - Next_Line (Nfirst .. Nlast - 8) := - Next_Line (Nfirst + 8 .. Nlast); - Nlast := Nlast - 8; - end if; + Next_Line (Nfirst .. Nlast - 8) := Next_Line (Nfirst + 8 .. Nlast); + Nlast := Nlast - 8; -- Go to next section when switches are reached @@ -1413,11 +1394,8 @@ procedure Gnatlink is Get_Next_Line; exit when Next_Line (Nfirst .. Nlast) = End_Info; - if Ada_Bind_File then - Next_Line (Nfirst .. Nlast - 8) := - Next_Line (Nfirst + 8 .. Nlast); - Nlast := Nlast - 8; - end if; + Next_Line (Nfirst .. Nlast - 8) := Next_Line (Nfirst + 8 .. Nlast); + Nlast := Nlast - 8; end loop; end if; @@ -1611,12 +1589,10 @@ begin elsif Arg'Length > 5 and then Arg (Arg'First + 2 .. Arg'First + 5) = "RTS=" then - if Ada_Bind_File then - Binder_Options_From_ALI.Increment_Last; - Binder_Options_From_ALI.Table - (Binder_Options_From_ALI.Last) - := String_Access (Arg); - end if; + Binder_Options_From_ALI.Increment_Last; + Binder_Options_From_ALI.Table + (Binder_Options_From_ALI.Last) + := String_Access (Arg); -- Set the RTS_*_Path_Name variables, so that -- the correct directories will be set when @@ -1666,14 +1642,9 @@ begin when CLI_Target => Gcc := new String'("dotnet-gnatcompile"); when No_VM => raise Program_Error; end case; - - Ada_Bind_File := True; - Begin_Info := "-- BEGIN Object file/option list"; - End_Info := "-- END Object file/option list "; end if; - -- If the main program is in Ada it is compiled with the following - -- switches: + -- Compile the bind file with the following switches: -- -gnatA stops reading gnat.adc, since we don't know what -- pragmas would work, and we do not need it anyway. @@ -1686,22 +1657,20 @@ begin -- In addition, in CodePeer mode compile with -gnatC - if Ada_Bind_File then - Binder_Options_From_ALI.Increment_Last; - Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := + Binder_Options_From_ALI.Increment_Last; + Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := new String'("-gnatA"); - Binder_Options_From_ALI.Increment_Last; - Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := + Binder_Options_From_ALI.Increment_Last; + Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := new String'("-gnatWb"); - Binder_Options_From_ALI.Increment_Last; - Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := + Binder_Options_From_ALI.Increment_Last; + Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := new String'("-gnatiw"); - if Opt.CodePeer_Mode then - Binder_Options_From_ALI.Increment_Last; - Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := + if Opt.CodePeer_Mode then + Binder_Options_From_ALI.Increment_Last; + Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := new String'("-gnatC"); - end if; end if; -- Locate all the necessary programs and verify required files are present @@ -1814,9 +1783,7 @@ begin begin -- Set prefix - if not Ada_Bind_File then - Bind_File_Prefix := new String'("b_"); - elsif OpenVMS_On_Target then + if OpenVMS_On_Target then Bind_File_Prefix := new String'("b__"); else Bind_File_Prefix := new String'("b~"); @@ -1839,13 +1806,9 @@ begin Fname (Fname'First .. Fname'First + Fname_Len - 1); begin - if Ada_Bind_File then - Binder_Spec_Src_File := new String'(Fnam & ".ads"); - Binder_Body_Src_File := new String'(Fnam & ".adb"); - Binder_Ali_File := new String'(Fnam & ".ali"); - else - Binder_Body_Src_File := new String'(Fnam & ".c"); - end if; + Binder_Spec_Src_File := new String'(Fnam & ".ads"); + Binder_Body_Src_File := new String'(Fnam & ".adb"); + Binder_Ali_File := new String'(Fnam & ".ali"); Binder_Obj_File := new String'(Fnam & Get_Target_Object_Suffix.all); end; @@ -2272,14 +2235,8 @@ begin -- useful if debugging. if not Debug_Flag_Present then - if Binder_Ali_File /= null then - Delete (Binder_Ali_File.all & ASCII.NUL); - end if; - - if Binder_Spec_Src_File /= null then - Delete (Binder_Spec_Src_File.all & ASCII.NUL); - end if; - + Delete (Binder_Ali_File.all & ASCII.NUL); + Delete (Binder_Spec_Src_File.all & ASCII.NUL); Delete (Binder_Body_Src_File.all & ASCII.NUL); if VM_Target = No_VM then diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb index 25b2da1f094..ce0bd19633a 100644 --- a/gcc/ada/gnatls.adb +++ b/gcc/ada/gnatls.adb @@ -1720,12 +1720,20 @@ begin Write_Line (To_Host_Dir_Spec (Name_Buffer (1 .. Name_Len), True).all); + Name_Len := Prefix_Name_Len; + Add_Str_To_Name_Buffer ("share" & Directory_Separator + & "gpr" & Directory_Separator); + Write_Str (" "); + Write_Line + (To_Host_Dir_Spec (Name_Buffer (1 .. Name_Len), True).all); + Name_Len := Prefix_Name_Len; Add_Str_To_Name_Buffer ("lib" & Directory_Separator & "gnat" & Directory_Separator); Write_Str (" "); Write_Line (To_Host_Dir_Spec (Name_Buffer (1 .. Name_Len), True).all); + end if; end if; end; diff --git a/gcc/ada/lib-xref-alfa.adb b/gcc/ada/lib-xref-alfa.adb index 9b78b438562..44a9d4438c6 100644 --- a/gcc/ada/lib-xref-alfa.adb +++ b/gcc/ada/lib-xref-alfa.adb @@ -550,9 +550,9 @@ package body ALFA is and then Ekind_In (Scope (E), E_Package, E_Package_Body); end Is_Global_Constant; - -- Start of processing for Eliminate_Before_Sort - begin + -- Start of processing for Eliminate_Before_Sort + begin NR := Nrefs; Nrefs := 0; diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index ec5cfb0f610..b2f39de056c 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -4359,8 +4359,8 @@ package body Make is end if; end if; - -- Put the object directories in ADA_OBJECTS_PATH - -- Ditto for source directories in ADA_INCLUDE_PATH in CodePeer mode + -- Put the object directories in ADA_OBJECTS_PATH. Same treatment for + -- source directories in ADA_INCLUDE_PATH if in CodePeer mode. Prj.Env.Set_Ada_Paths (Main_Project, diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb index f091690eb1f..0286267dcc2 100644 --- a/gcc/ada/makeutl.adb +++ b/gcc/ada/makeutl.adb @@ -1389,12 +1389,12 @@ package body Makeutl is if Name_Len > Base_Main'Length and then Name_Buffer (1 .. Base_Main'Length) = Base_Main then - Suffix := - Source.Language.Config.Naming_Data.Spec_Suffix; + Suffix := Source.Language.Config.Naming_Data.Spec_Suffix; if Suffix /= No_File then declare Suffix_Str : String := Get_Name_String (Suffix); + begin Canonical_Case_File_Name (Suffix_Str); diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index ec121360007..d4d03738bd2 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -112,10 +112,6 @@ package Opt is -- case of some binder variables, Gnatbind.Scan_Bind_Arg may modify -- the default values. - Ada_Bind_File : Boolean := True; - -- GNATBIND, GNATLINK - -- Set True if binder file to be generated in Ada rather than C - type Ada_Version_Type is (Ada_83, Ada_95, Ada_2005, Ada_2012); pragma Ordered (Ada_Version_Type); -- Versions of Ada for Ada_Version below. Note that these are ordered, diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb index 5f5b831368b..0c66142e0d4 100644 --- a/gcc/ada/prj-env.adb +++ b/gcc/ada/prj-env.adb @@ -1982,7 +1982,6 @@ package body Prj.Env is if Add_Default_Dir then declare Prefix : String_Ptr; - Add_Prefix_Share_Gpr : Boolean; begin if Sdefault.Search_Dir_Prefix = null then @@ -1990,7 +1989,6 @@ package body Prj.Env is -- gprbuild case Prefix := new String'(Executable_Prefix_Path); - Add_Prefix_Share_Gpr := True; else Prefix := new String'(Sdefault.Search_Dir_Prefix.all @@ -1998,7 +1996,6 @@ package body Prj.Env is & ".." & Dir_Separator & ".." & Dir_Separator & ".." & Dir_Separator); - Add_Prefix_Share_Gpr := False; end if; if Prefix.all /= "" then @@ -2021,14 +2018,11 @@ package body Prj.Env is ("lib" & Directory_Separator & "gnat"); end if; - if Add_Prefix_Share_Gpr then + -- $prefix/share/gpr - -- $prefix/share/gpr - - Add_Str_To_Name_Buffer - (Path_Separator & Prefix.all & - "share" & Directory_Separator & "gpr"); - end if; + Add_Str_To_Name_Buffer + (Path_Separator & Prefix.all & + "share" & Directory_Separator & "gpr"); -- $prefix/lib/gnat diff --git a/gcc/ada/projects.texi b/gcc/ada/projects.texi index f5cc8ae71dc..4603a4f9df9 100644 --- a/gcc/ada/projects.texi +++ b/gcc/ada/projects.texi @@ -1135,7 +1135,8 @@ the search stops: @itemize @bullet @item @file{//lib/gnat} - (for @command{gprbuild} only and if option @option{--target} is specified) + (for @command{gnatmake} in all cases, and for @command{gprbuild} if option + @option{--target} is specified) @item @file{/share/gpr/} (for @command{gnatmake} and @command{gprbuild}) @item @file{/lib/gnat/} diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 7dc34d83a18..c3d558928ea 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -2690,6 +2690,8 @@ package body Sem_Ch12 is Decl : Node_Id; begin + Check_SPARK_Restriction ("generic is not allowed", N); + -- We introduce a renaming of the enclosing package, to have a usable -- entity as the prefix of an expanded name for a local entity of the -- form Par.P.Q, where P is the generic package. This is because a local @@ -2811,6 +2813,8 @@ package body Sem_Ch12 is Typ : Entity_Id; begin + Check_SPARK_Restriction ("generic is not allowed", N); + -- Create copy of generic unit, and save for instantiation. If the unit -- is a child unit, do not copy the specifications for the parent, which -- are not part of the generic tree. @@ -3051,6 +3055,8 @@ package body Sem_Ch12 is -- Start of processing for Analyze_Package_Instantiation begin + Check_SPARK_Restriction ("generic is not allowed", N); + -- Very first thing: apply the special kludge for Text_IO processing -- in case we are instantiating one of the children of [Wide_]Text_IO. @@ -4195,6 +4201,8 @@ package body Sem_Ch12 is -- Start of processing for Analyze_Subprogram_Instantiation begin + Check_SPARK_Restriction ("generic is not allowed", N); + -- Very first thing: apply the special kludge for Text_IO processing -- in case we are instantiating one of the children of [Wide_]Text_IO. -- Of course such an instantiation is bogus (these are packages, not diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 4e8ae6d6a57..127d93d99bb 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2064,14 +2064,14 @@ package body Sem_Ch3 is D := First (L); while Present (D) loop - -- Package specification cannot contain a package declaration in - -- SPARK. + -- Package spec cannot contain a package declaration in SPARK if Nkind (D) = N_Package_Declaration and then Nkind (Parent (L)) = N_Package_Specification then - Check_SPARK_Restriction ("package specification cannot contain " - & "a package declaration", D); + Check_SPARK_Restriction + ("package specification cannot contain a package declaration", + D); end if; -- Complete analysis of declaration diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 8c95ada1cc4..fe9cb2ef526 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -422,9 +422,7 @@ package body Sem_Prag is -- Checks that the given argument has an identifier, and if so, requires -- it to match one of the given identifier names. If there is no -- identifier, or a non-matching identifier, then an error message is - -- given and Pragma_Exit is raised. This checks the optional identifier - -- of a pragma argument, not the argument itself like - -- Check_Arg_Is_One_Of does. + -- given and Pragma_Exit is raised. procedure Check_In_Main_Program; -- Common checks for pragmas that appear within a main program @@ -13247,18 +13245,20 @@ package body Sem_Prag is -- Test_Case -- --------------- - -- pragma Test_Case ([Name =>] static_string_EXPRESSION - -- ,[Mode =>] (Normal | Robustness) + -- pragma Test_Case ([Name =>] Static_String_EXPRESSION + -- ,[Mode =>] MODE_TYPE -- [, Requires => Boolean_EXPRESSION] -- [, Ensures => Boolean_EXPRESSION]); + -- MODE_TYPE ::= Normal | Robustness + when Pragma_Test_Case => Test_Case : declare begin GNAT_Pragma; Check_At_Least_N_Arguments (3); Check_At_Most_N_Arguments (4); Check_Arg_Order - ((Name_Name, Name_Mode, Name_Requires, Name_Ensures)); + ((Name_Name, Name_Mode, Name_Requires, Name_Ensures)); Check_Optional_Identifier (Arg1, Name_Name); Check_Arg_Is_Static_Expression (Arg1, Standard_String); diff --git a/gcc/ada/switch-b.adb b/gcc/ada/switch-b.adb index 0d44aa8be80..8b662676c0c 100644 --- a/gcc/ada/switch-b.adb +++ b/gcc/ada/switch-b.adb @@ -26,7 +26,6 @@ with Debug; use Debug; with Osint; use Osint; with Opt; use Opt; -with Output; use Output; with System.WCh_Con; use System.WCh_Con; @@ -166,14 +165,6 @@ package body Switch.B is Ptr := Ptr + 1; Check_Only := True; - -- Processing for C switch - - when 'C' => - Ptr := Ptr + 1; - Ada_Bind_File := False; - - Write_Line ("warning: gnatbind switch -C is obsolescent"); - -- Processing for d switch when 'd' => -- cgit v1.2.1