1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
28 with Binde; use Binde;
29 with Butil; use Butil;
30 with Casing; use Casing;
31 with Fname; use Fname;
32 with GNAT.OS_Lib; use GNAT.OS_Lib;
33 with Gnatvsn; use Gnatvsn;
35 with Namet; use Namet;
37 with Osint; use Osint;
38 with Osint.B; use Osint.B;
39 with Output; use Output;
40 with Rident; use Rident;
41 with Table; use Table;
42 with Targparm; use Targparm;
43 with Types; use Types;
45 with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
47 package body Bindgen is
49 Statement_Buffer : String (1 .. 1000);
50 -- Buffer used for constructing output statements
53 -- Last location in Statement_Buffer currently set
55 With_DECGNAT : Boolean := False;
56 -- Flag which indicates whether the program uses the DECGNAT library
57 -- (presence of the unit DEC).
59 With_GNARL : Boolean := False;
60 -- Flag which indicates whether the program uses the GNARL library
61 -- (presence of the unit System.OS_Interface)
63 Num_Elab_Calls : Nat := 0;
64 -- Number of generated calls to elaboration routines
66 ----------------------------------
67 -- Interface_State Pragma Table --
68 ----------------------------------
70 -- This table assembles the interface state pragma information from
71 -- all the units in the partition. Note that Bcheck has already checked
72 -- that the information is consistent across partitions. The entries
73 -- in this table are n/u/r/s for not set/user/runtime/system.
75 package IS_Pragma_Settings is new Table.Table (
76 Table_Component_Type => Character,
77 Table_Index_Type => Int,
80 Table_Increment => 200,
81 Table_Name => "IS_Pragma_Settings");
83 ----------------------
84 -- Run-Time Globals --
85 ----------------------
87 -- This section documents the global variables that are passed to the
88 -- run time from the generated binder file. The call that is made is
89 -- to the routine Set_Globals, which has the following spec:
91 -- procedure Set_Globals
92 -- (Main_Priority : Integer;
93 -- Time_Slice_Value : Integer;
94 -- WC_Encoding : Character;
95 -- Locking_Policy : Character;
96 -- Queuing_Policy : Character;
97 -- Task_Dispatching_Policy : Character;
98 -- Restrictions : System.Address;
99 -- Interrupt_States : System.Address;
100 -- Num_Interrupt_States : Integer;
101 -- Unreserve_All_Interrupts : Integer;
102 -- Exception_Tracebacks : Integer;
103 -- Zero_Cost_Exceptions : Integer);
105 -- Main_Priority is the priority value set by pragma Priority in the
106 -- main program. If no such pragma is present, the value is -1.
108 -- Time_Slice_Value is the time slice value set by pragma Time_Slice
109 -- in the main program, or by the use of a -Tnnn parameter for the
110 -- binder (if both are present, the binder value overrides). The
111 -- value is in milliseconds. A value of zero indicates that time
112 -- slicing should be suppressed. If no pragma is present, and no
113 -- -T switch was used, the value is -1.
115 -- WC_Encoding shows the wide character encoding method used for
116 -- the main program. This is one of the encoding letters defined
117 -- in System.WCh_Con.WC_Encoding_Letters.
119 -- Locking_Policy is a space if no locking policy was specified
120 -- for the partition. If a locking policy was specified, the value
121 -- is the upper case first character of the locking policy name,
122 -- for example, 'C' for Ceiling_Locking.
124 -- Queuing_Policy is a space if no queuing policy was specified
125 -- for the partition. If a queuing policy was specified, the value
126 -- is the upper case first character of the queuing policy name
127 -- for example, 'F' for FIFO_Queuing.
129 -- Task_Dispatching_Policy is a space if no task dispatching policy
130 -- was specified for the partition. If a task dispatching policy
131 -- was specified, the value is the upper case first character of
132 -- the policy name, e.g. 'F' for FIFO_Within_Priorities.
134 -- Restrictions is the address of a null-terminated string specifying the
135 -- restrictions information for the partition. The format is identical to
136 -- that of the parameter string found on R lines in ali files (see Lib.Writ
137 -- spec in lib-writ.ads for full details). The difference is that in this
138 -- context the values are the cumulative ones for the entire partition.
140 -- Interrupt_States is the address of a string used to specify the
141 -- cumulative results of Interrupt_State pragmas used in the partition.
142 -- The length of this string is determined by the last interrupt for which
143 -- such a pragma is given (the string will be a null string if no pragmas
144 -- were used). If pragma were present the entries apply to the interrupts
145 -- in sequence from the first interrupt, and are set to one of four
146 -- possible settings: 'n' for not specified, 'u' for user, 'r' for
147 -- run time, 's' for system, see description of Interrupt_State pragma
148 -- for further details.
150 -- Num_Interrupt_States is the length of the Interrupt_States string.
151 -- It will be set to zero if no Interrupt_State pragmas are present.
153 -- Unreserve_All_Interrupts is set to one if at least one unit in the
154 -- partition had a pragma Unreserve_All_Interrupts, and zero otherwise.
156 -- Exception_Tracebacks is set to one if the -E parameter was present
157 -- in the bind and to zero otherwise. Note that on some targets exception
158 -- tracebacks are provided by default, so a value of zero for this
159 -- parameter does not necessarily mean no trace backs are available.
161 -- Zero_Cost_Exceptions is set to one if zero cost exceptions are used for
162 -- this partition, and to zero if longjmp/setjmp exceptions are used.
165 -----------------------
166 -- Local Subprograms --
167 -----------------------
169 procedure WBI (Info : String) renames Osint.B.Write_Binder_Info;
170 -- Convenient shorthand used throughout
172 procedure Gen_Adainit_Ada;
173 -- Generates the Adainit procedure (Ada code case)
175 procedure Gen_Adainit_C;
176 -- Generates the Adainit procedure (C code case)
178 procedure Gen_Adafinal_Ada;
179 -- Generate the Adafinal procedure (Ada code case)
181 procedure Gen_Adafinal_C;
182 -- Generate the Adafinal procedure (C code case)
184 procedure Gen_Elab_Calls_Ada;
185 -- Generate sequence of elaboration calls (Ada code case)
187 procedure Gen_Elab_Calls_C;
188 -- Generate sequence of elaboration calls (C code case)
190 procedure Gen_Elab_Order_Ada;
191 -- Generate comments showing elaboration order chosen (Ada case)
193 procedure Gen_Elab_Order_C;
194 -- Generate comments showing elaboration order chosen (C case)
196 procedure Gen_Elab_Defs_C;
197 -- Generate sequence of definitions for elaboration routines (C code case)
199 procedure Gen_Exception_Table_Ada;
200 -- Generate binder exception table (Ada code case). This consists of
201 -- declarations followed by a begin followed by a call. If zero cost
202 -- exceptions are not active, then only the begin is generated.
204 procedure Gen_Exception_Table_C;
205 -- Generate binder exception table (C code case). This has no effect
206 -- if zero cost exceptions are not active, otherwise it generates a
207 -- set of declarations followed by a call.
209 procedure Gen_Main_Ada;
210 -- Generate procedure main (Ada code case)
212 procedure Gen_Main_C;
213 -- Generate main() procedure (C code case)
215 procedure Gen_Object_Files_Options;
216 -- Output comments containing a list of the full names of the object
217 -- files to be linked and the list of linker options supplied by
218 -- Linker_Options pragmas in the source. (C and Ada code case)
220 procedure Gen_Output_File_Ada (Filename : String);
221 -- Generate output file (Ada code case)
223 procedure Gen_Output_File_C (Filename : String);
224 -- Generate output file (C code case)
226 procedure Gen_Restrictions_String_1;
227 -- Generate first restrictions string, which consists of the parameters
228 -- the first R line, as described in lib-writ.ads, with the restrictions
229 -- being those for the entire partition (from Cumulative_Restrictions).
231 procedure Gen_Restrictions_String_2;
232 -- Generate first restrictions string, which consists of the parameters
233 -- the second R line, as described in lib-writ.ads, with the restrictions
234 -- being those for the entire partition (from Cumulative_Restrictions).
236 procedure Gen_Versions_Ada;
237 -- Output series of definitions for unit versions (Ada code case)
239 procedure Gen_Versions_C;
240 -- Output series of definitions for unit versions (C code case)
242 function Get_Ada_Main_Name return String;
243 -- This function is used in the Ada main output case to compute a usable
244 -- name for the generated main program. The normal main program name is
245 -- Ada_Main, but this won't work if the user has a unit with this name.
246 -- This function tries Ada_Main first, and if there is such a clash, then
247 -- it tries Ada_Name_01, Ada_Name_02 ... Ada_Name_99 in sequence.
249 function Get_Main_Name return String;
250 -- This function is used in the Ada main output case to compute the
251 -- correct external main program. It is "main" by default, unless the
252 -- flag Use_Ada_Main_Program_Name_On_Target is set, in which case it
253 -- is the name of the Ada main name without the "_ada". This default
254 -- can be overridden explicitly using the -Mname binder switch.
256 function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean;
257 -- Compare linker options, when sorting, first according to
258 -- Is_Internal_File (internal files come later) and then by
259 -- elaboration order position (latest to earliest).
261 procedure Move_Linker_Option (From : Natural; To : Natural);
262 -- Move routine for sorting linker options
264 procedure Public_Version_Warning;
265 -- Emit a warning concerning the use of the Public version under
266 -- certain circumstances. See details in body.
268 procedure Resolve_Binder_Options;
269 -- Set the value of With_GNARL and With_DECGNAT. The latter only on VMS
270 -- since it tests for a package named "dec" which might cause a conflict
271 -- on non-VMS systems.
273 procedure Set_Char (C : Character);
274 -- Set given character in Statement_Buffer at the Last + 1 position
275 -- and increment Last by one to reflect the stored character.
277 procedure Set_Int (N : Int);
278 -- Set given value in decimal in Statement_Buffer with no spaces
279 -- starting at the Last + 1 position, and updating Last past the value.
280 -- A minus sign is output for a negative value.
282 procedure Set_IS_Pragma_Table;
283 -- Initializes contents of IS_Pragma_Settings table from ALI table
285 procedure Set_Main_Program_Name;
286 -- Given the main program name in Name_Buffer (length in Name_Len)
287 -- generate the name of the routine to be used in the call. The name
288 -- is generated starting at Last + 1, and Last is updated past it.
290 procedure Set_Name_Buffer;
291 -- Set the value stored in positions 1 .. Name_Len of the Name_Buffer.
293 procedure Set_String (S : String);
294 -- Sets characters of given string in Statement_Buffer, starting at the
295 -- Last + 1 position, and updating last past the string value.
297 procedure Set_Unit_Name;
298 -- Given a unit name in the Name_Buffer, copies it to Statement_Buffer,
299 -- starting at the Last + 1 position, and updating last past the value.
300 -- changing periods to double underscores, and updating Last appropriately.
302 procedure Set_Unit_Number (U : Unit_Id);
303 -- Sets unit number (first unit is 1, leading zeroes output to line
304 -- up all output unit numbers nicely as required by the value, and
305 -- by the total number of units.
307 procedure Tab_To (N : Natural);
308 -- If Last is greater than or equal to N, no effect, otherwise store
309 -- blanks in Statement_Buffer bumping Last, until Last = N.
311 procedure Write_Info_Ada_C (Ada : String; C : String; Common : String);
312 -- For C code case, write C & Common, for Ada case write Ada & Common
313 -- to current binder output file using Write_Binder_Info.
315 procedure Write_Statement_Buffer;
316 -- Write out contents of statement buffer up to Last, and reset Last to 0
318 procedure Write_Statement_Buffer (S : String);
319 -- First writes its argument (using Set_String (S)), then writes out the
320 -- contents of statement buffer up to Last, and reset Last to 0
322 ----------------------
323 -- Gen_Adafinal_Ada --
324 ----------------------
326 procedure Gen_Adafinal_Ada is
329 WBI (" procedure " & Ada_Final_Name.all & " is");
332 -- If compiling for the JVM, we directly call Adafinal because
333 -- we don't import it via Do_Finalize (see Gen_Output_File_Ada).
335 if Hostparm.Java_VM then
336 WBI (" System.Standard_Library.Adafinal;");
338 WBI (" Do_Finalize;");
341 WBI (" end " & Ada_Final_Name.all & ";");
342 end Gen_Adafinal_Ada;
348 procedure Gen_Adafinal_C is
350 WBI ("void " & Ada_Final_Name.all & " () {");
351 WBI (" system__standard_library__adafinal ();");
356 ---------------------
357 -- Gen_Adainit_Ada --
358 ---------------------
360 procedure Gen_Adainit_Ada is
361 Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority;
364 WBI (" procedure " & Ada_Init_Name.all & " is");
366 -- Generate externals for elaboration entities
368 for E in Elab_Order.First .. Elab_Order.Last loop
370 Unum : constant Unit_Id := Elab_Order.Table (E);
371 U : Unit_Record renames Units.Table (Unum);
374 -- Check for Elab_Entity to be set for this unit
378 -- Don't generate reference for stand alone library
380 and then not U.Interface
382 -- Don't generate reference for predefined file in No_Run_Time
383 -- mode, since we don't include the object files in this case
387 and then Is_Predefined_File_Name (U.Sfile))
391 Set_Unit_Number (Unum);
392 Set_String (" : Boolean; pragma Import (Ada, ");
394 Set_Unit_Number (Unum);
396 Get_Name_String (U.Uname);
398 -- In the case of JGNAT we need to emit an Import name
399 -- that includes the class name (using '$' separators
400 -- in the case of a child unit name).
402 if Hostparm.Java_VM then
403 for J in 1 .. Name_Len - 2 loop
404 if Name_Buffer (J) /= '.' then
405 Set_Char (Name_Buffer (J));
413 -- If the unit name is very long, then split the
414 -- Import link name across lines using "&" (occurs
415 -- in some C2 tests).
417 if 2 * Name_Len + 60 > Hostparm.Max_Line_Length then
419 Write_Statement_Buffer;
425 Set_String ("_E"");");
426 Write_Statement_Buffer;
431 Write_Statement_Buffer;
433 -- If the standard library is suppressed, then the only global variable
434 -- that might be needed (by the Ravenscar profile) is the priority of
435 -- the environment. Also no exception tables are needed.
437 if Suppress_Standard_Library_On_Target then
438 if Main_Priority /= No_Main_Priority then
439 WBI (" Main_Priority : Integer;");
440 WBI (" pragma Import (C, Main_Priority," &
441 " ""__gl_main_priority"");");
447 if Main_Priority /= No_Main_Priority then
448 Set_String (" Main_Priority := ");
449 Set_Int (Main_Priority);
451 Write_Statement_Buffer;
457 -- Normal case (standard library not suppressed). Global values are
458 -- assigned using the runtime routine Set_Globals (we have to use
459 -- the routine call, rather than define the globals in the binder
460 -- file to deal with cross-library calls in some systems.
463 -- Generate restrictions string
465 Set_String (" Restrictions : constant String :=");
466 Write_Statement_Buffer;
469 Gen_Restrictions_String_1;
471 Write_Statement_Buffer;
474 Gen_Restrictions_String_2;
475 Set_String (""" & ASCII.Nul;");
476 Write_Statement_Buffer;
479 -- Generate Interrupt_State pragma string
481 Set_String (" Interrupt_States : constant String :=");
482 Write_Statement_Buffer;
491 for J in 0 .. IS_Pragma_Settings.Last loop
494 Write_Statement_Buffer;
502 Set_Char (IS_Pragma_Settings.Table (J));
507 Write_Statement_Buffer;
510 -- Generate spec for Set_Globals procedure
512 WBI (" procedure Set_Globals");
513 WBI (" (Main_Priority : Integer;");
514 WBI (" Time_Slice_Value : Integer;");
515 WBI (" WC_Encoding : Character;");
516 WBI (" Locking_Policy : Character;");
517 WBI (" Queuing_Policy : Character;");
518 WBI (" Task_Dispatching_Policy : Character;");
519 WBI (" Restrictions : System.Address;");
520 WBI (" Interrupt_States : System.Address;");
521 WBI (" Num_Interrupt_States : Integer;");
522 WBI (" Unreserve_All_Interrupts : Integer;");
523 WBI (" Exception_Tracebacks : Integer;");
524 WBI (" Zero_Cost_Exceptions : Integer);");
525 WBI (" pragma Import (C, Set_Globals, ""__gnat_set_globals"");");
527 -- Import entry point for elaboration time signal handler
528 -- installation, and indication of if it's been called previously.
531 WBI (" procedure Install_Handler;");
532 WBI (" pragma Import (C, Install_Handler, " &
533 """__gnat_install_handler"");");
535 WBI (" Handler_Installed : Integer;");
536 WBI (" pragma Import (C, Handler_Installed, " &
537 """__gnat_handler_installed"");");
539 -- Generate exception table
541 Gen_Exception_Table_Ada;
543 -- Generate the call to Set_Globals
545 WBI (" Set_Globals");
547 Set_String (" (Main_Priority => ");
548 Set_Int (Main_Priority);
550 Write_Statement_Buffer;
552 Set_String (" Time_Slice_Value => ");
554 if Task_Dispatching_Policy_Specified = 'F'
555 and then ALIs.Table (ALIs.First).Time_Slice_Value = -1
559 Set_Int (ALIs.Table (ALIs.First).Time_Slice_Value);
563 Write_Statement_Buffer;
565 Set_String (" WC_Encoding => '");
566 Set_Char (ALIs.Table (ALIs.First).WC_Encoding);
568 Write_Statement_Buffer;
570 Set_String (" Locking_Policy => '");
571 Set_Char (Locking_Policy_Specified);
573 Write_Statement_Buffer;
575 Set_String (" Queuing_Policy => '");
576 Set_Char (Queuing_Policy_Specified);
578 Write_Statement_Buffer;
580 Set_String (" Task_Dispatching_Policy => '");
581 Set_Char (Task_Dispatching_Policy_Specified);
583 Write_Statement_Buffer;
585 WBI (" Restrictions => Restrictions'Address,");
587 WBI (" Interrupt_States => " &
588 "Interrupt_States'Address,");
590 Set_String (" Num_Interrupt_States => ");
591 Set_Int (IS_Pragma_Settings.Last + 1);
593 Write_Statement_Buffer;
595 Set_String (" Unreserve_All_Interrupts => ");
597 if Unreserve_All_Interrupts_Specified then
604 Write_Statement_Buffer;
606 Set_String (" Exception_Tracebacks => ");
608 if Exception_Tracebacks then
615 Write_Statement_Buffer;
617 Set_String (" Zero_Cost_Exceptions => ");
619 if Zero_Cost_Exceptions_Specified then
626 Write_Statement_Buffer;
628 -- Generate call to Install_Handler
631 WBI (" if Handler_Installed = 0 then");
632 WBI (" Install_Handler;");
636 -- Generate call to set Initialize_Scalar values if active
638 if Initialize_Scalars_Used then
640 Set_String (" System.Scalar_Values.Initialize ('");
641 Set_Char (Initialize_Scalars_Mode1);
643 Set_Char (Initialize_Scalars_Mode2);
645 Write_Statement_Buffer;
648 -- Generate assignment of default secondary stack size if set
650 if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then
652 Set_String (" System.Secondary_Stack.");
653 Set_String ("Default_Secondary_Stack_Size := ");
654 Set_Int (Opt.Default_Sec_Stack_Size);
656 Write_Statement_Buffer;
659 -- Generate elaboration calls
664 WBI (" end " & Ada_Init_Name.all & ";");
671 procedure Gen_Adainit_C is
672 Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority;
675 WBI ("void " & Ada_Init_Name.all & " (void)");
678 -- Generate externals for elaboration entities
680 for E in Elab_Order.First .. Elab_Order.Last loop
682 Unum : constant Unit_Id := Elab_Order.Table (E);
683 U : Unit_Record renames Units.Table (Unum);
686 -- Check for Elab entity to be set for this unit
690 -- Don't generate reference for stand alone library
692 and then not U.Interface
694 -- Don't generate reference for predefined file in No_Run_Time
695 -- mode, since we don't include the object files in this case
699 and then Is_Predefined_File_Name (U.Sfile))
701 Set_String (" extern char ");
702 Get_Name_String (U.Uname);
705 Write_Statement_Buffer;
710 Write_Statement_Buffer;
712 -- Standard library suppressed
714 if Suppress_Standard_Library_On_Target then
716 -- Case of High_Integrity_Mode mode. Set __gl_main_priority if needed
717 -- for the Ravenscar profile.
719 if Main_Priority /= No_Main_Priority then
720 Set_String (" extern int __gl_main_priority = ");
721 Set_Int (Main_Priority);
723 Write_Statement_Buffer;
726 -- Normal case (standard library not suppressed)
729 -- Generate definition for restrictions string
731 Set_String (" const char *restrictions = """);
732 Gen_Restrictions_String_1;
733 Gen_Restrictions_String_2;
735 Write_Statement_Buffer;
737 -- Generate definition for interrupt states string
739 Set_String (" const char *interrupt_states = """);
741 for J in 0 .. IS_Pragma_Settings.Last loop
742 Set_Char (IS_Pragma_Settings.Table (J));
746 Write_Statement_Buffer;
748 -- Generate declaration for secondary stack default if needed
750 if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then
751 WBI (" extern int system__secondary_stack__" &
752 "default_secondary_stack_size;");
757 -- Code for normal case (standard library not suppressed)
759 Gen_Exception_Table_C;
761 -- Generate call to set the runtime global variables defined in
762 -- a-init.c. We define the varables in a-init.c, rather than in
763 -- the binder generated file itself to avoid undefined externals
764 -- when the runtime is linked as a shareable image library.
766 -- We call the routine from inside adainit() because this works for
767 -- both programs with and without binder generated "main" functions.
769 WBI (" __gnat_set_globals (");
772 Set_Int (Main_Priority);
775 Set_String ("/* Main_Priority */");
776 Write_Statement_Buffer;
780 if Task_Dispatching_Policy = 'F'
781 and then ALIs.Table (ALIs.First).Time_Slice_Value = -1
785 Set_Int (ALIs.Table (ALIs.First).Time_Slice_Value);
790 Set_String ("/* Time_Slice_Value */");
791 Write_Statement_Buffer;
794 Set_Char (ALIs.Table (ALIs.First).WC_Encoding);
797 Set_String ("/* WC_Encoding */");
798 Write_Statement_Buffer;
801 Set_Char (Locking_Policy_Specified);
804 Set_String ("/* Locking_Policy */");
805 Write_Statement_Buffer;
808 Set_Char (Queuing_Policy_Specified);
811 Set_String ("/* Queuing_Policy */");
812 Write_Statement_Buffer;
815 Set_Char (Task_Dispatching_Policy_Specified);
818 Set_String ("/* Tasking_Dispatching_Policy */");
819 Write_Statement_Buffer;
822 Set_String ("restrictions");
825 Set_String ("/* Restrictions */");
826 Write_Statement_Buffer;
829 Set_String ("interrupt_states");
832 Set_String ("/* Interrupt_States */");
833 Write_Statement_Buffer;
836 Set_Int (IS_Pragma_Settings.Last + 1);
839 Set_String ("/* Num_Interrupt_States */");
840 Write_Statement_Buffer;
843 Set_Int (Boolean'Pos (Unreserve_All_Interrupts_Specified));
846 Set_String ("/* Unreserve_All_Interrupts */");
847 Write_Statement_Buffer;
850 Set_Int (Boolean'Pos (Exception_Tracebacks));
853 Set_String ("/* Exception_Tracebacks */");
854 Write_Statement_Buffer;
857 Set_Int (Boolean'Pos (Zero_Cost_Exceptions_Specified));
860 Set_String ("/* Zero_Cost_Exceptions */");
861 Write_Statement_Buffer;
864 -- Install elaboration time signal handler
866 WBI (" if (__gnat_handler_installed == 0)");
868 WBI (" __gnat_install_handler ();");
872 -- Generate call to set Initialize_Scalar values if needed
874 if Initialize_Scalars_Used then
876 Set_String (" system__scalar_values__initialize('");
877 Set_Char (Initialize_Scalars_Mode1);
879 Set_Char (Initialize_Scalars_Mode2);
881 Write_Statement_Buffer;
884 -- Generate assignment of default secondary stack size if set
886 if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then
888 Set_String (" system__secondary_stack__");
889 Set_String ("default_secondary_stack_size = ");
890 Set_Int (Opt.Default_Sec_Stack_Size);
892 Write_Statement_Buffer;
895 -- Generate elaboration calls
902 ------------------------
903 -- Gen_Elab_Calls_Ada --
904 ------------------------
906 procedure Gen_Elab_Calls_Ada is
908 for E in Elab_Order.First .. Elab_Order.Last loop
910 Unum : constant Unit_Id := Elab_Order.Table (E);
911 U : Unit_Record renames Units.Table (Unum);
914 -- This is the unit number of the spec that corresponds to
915 -- this entry. It is the same as Unum except when the body
916 -- and spec are different and we are currently processing
917 -- the body, in which case it is the spec (Unum + 1).
920 if U.Utype = Is_Body then
921 Unum_Spec := Unum + 1;
926 -- Nothing to do if predefined unit in no run time mode
928 if No_Run_Time_Mode and then Is_Predefined_File_Name (U.Sfile) then
931 -- Case of no elaboration code
935 -- The only case in which we have to do something is if
936 -- this is a body, with a separate spec, where the separate
937 -- spec has an elaboration entity defined.
939 -- In that case, this is where we set the elaboration entity
940 -- to True, we do not need to test if this has already been
941 -- done, since it is quicker to set the flag than to test it.
943 if not U.Interface and then U.Utype = Is_Body
944 and then Units.Table (Unum_Spec).Set_Elab_Entity
947 Set_Unit_Number (Unum_Spec);
948 Set_String (" := True;");
949 Write_Statement_Buffer;
952 -- Here if elaboration code is present. If binding a library
953 -- or if there is a non-Ada main subprogram then we generate:
955 -- if not uname_E then
956 -- uname'elab_[spec|body];
960 -- Otherwise, elaboration routines are called unconditionally:
962 -- uname'elab_[spec|body];
965 -- The uname_E assignment is skipped if this is a separate spec,
966 -- since the assignment will be done when we process the body.
968 elsif not U.Interface then
969 if Force_Checking_Of_Elaboration_Flags or
970 Interface_Library_Unit or
971 (not Bind_Main_Program)
973 Set_String (" if not E");
974 Set_Unit_Number (Unum_Spec);
975 Set_String (" then");
976 Write_Statement_Buffer;
981 Get_Decoded_Name_String_With_Brackets (U.Uname);
983 if Name_Buffer (Name_Len) = 's' then
984 Name_Buffer (Name_Len - 1 .. Name_Len + 8) := "'elab_spec";
986 Name_Buffer (Name_Len - 1 .. Name_Len + 8) := "'elab_body";
989 Name_Len := Name_Len + 8;
990 Set_Casing (U.Icasing);
993 Write_Statement_Buffer;
995 if U.Utype /= Is_Spec then
996 if Force_Checking_Of_Elaboration_Flags or
997 Interface_Library_Unit or
998 (not Bind_Main_Program)
1004 Set_Unit_Number (Unum_Spec);
1005 Set_String (" := True;");
1006 Write_Statement_Buffer;
1009 if Force_Checking_Of_Elaboration_Flags or
1010 Interface_Library_Unit or
1011 (not Bind_Main_Program)
1018 end Gen_Elab_Calls_Ada;
1020 ----------------------
1021 -- Gen_Elab_Calls_C --
1022 ----------------------
1024 procedure Gen_Elab_Calls_C is
1026 for E in Elab_Order.First .. Elab_Order.Last loop
1028 Unum : constant Unit_Id := Elab_Order.Table (E);
1029 U : Unit_Record renames Units.Table (Unum);
1031 Unum_Spec : Unit_Id;
1032 -- This is the unit number of the spec that corresponds to
1033 -- this entry. It is the same as Unum except when the body
1034 -- and spec are different and we are currently processing
1035 -- the body, in which case it is the spec (Unum + 1).
1038 if U.Utype = Is_Body then
1039 Unum_Spec := Unum + 1;
1044 -- Nothing to do if predefined unit in no run time mode
1046 if No_Run_Time_Mode and then Is_Predefined_File_Name (U.Sfile) then
1049 -- Case of no elaboration code
1051 elsif U.No_Elab then
1053 -- The only case in which we have to do something is if
1054 -- this is a body, with a separate spec, where the separate
1055 -- spec has an elaboration entity defined.
1057 -- In that case, this is where we set the elaboration entity
1058 -- to True, we do not need to test if this has already been
1059 -- done, since it is quicker to set the flag than to test it.
1061 if not U.Interface and then U.Utype = Is_Body
1062 and then Units.Table (Unum_Spec).Set_Elab_Entity
1065 Get_Name_String (U.Uname);
1067 Set_String ("_E = 1;");
1068 Write_Statement_Buffer;
1071 -- Here if elaboration code is present. If binding a library
1072 -- or if there is a non-Ada main subprogram then we generate:
1074 -- if (uname_E == 0) {
1075 -- uname__elab[s|b] ();
1079 -- The uname_E assignment is skipped if this is a separate spec,
1080 -- since the assignment will be done when we process the body.
1082 elsif not U.Interface then
1083 Get_Name_String (U.Uname);
1085 if Force_Checking_Of_Elaboration_Flags or
1086 Interface_Library_Unit or
1087 (not Bind_Main_Program)
1089 Set_String (" if (");
1091 Set_String ("_E == 0) {");
1092 Write_Statement_Buffer;
1098 Set_String ("___elab");
1099 Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body
1100 Set_String (" ();");
1101 Write_Statement_Buffer;
1103 if U.Utype /= Is_Spec then
1104 if Force_Checking_Of_Elaboration_Flags or
1105 Interface_Library_Unit or
1106 (not Bind_Main_Program)
1113 Set_String ("_E++;");
1114 Write_Statement_Buffer;
1117 if Force_Checking_Of_Elaboration_Flags or
1118 Interface_Library_Unit or
1119 (not Bind_Main_Program)
1127 end Gen_Elab_Calls_C;
1129 ----------------------
1130 -- Gen_Elab_Defs_C --
1131 ----------------------
1133 procedure Gen_Elab_Defs_C is
1135 for E in Elab_Order.First .. Elab_Order.Last loop
1137 -- Generate declaration of elaboration procedure if elaboration
1138 -- needed. Note that passive units are always excluded.
1140 if not Units.Table (Elab_Order.Table (E)).No_Elab then
1141 Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
1142 Set_String ("extern void ");
1144 Set_String ("___elab");
1145 Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body
1146 Set_String (" (void);");
1147 Write_Statement_Buffer;
1153 end Gen_Elab_Defs_C;
1155 ------------------------
1156 -- Gen_Elab_Order_Ada --
1157 ------------------------
1159 procedure Gen_Elab_Order_Ada is
1162 WBI (" -- BEGIN ELABORATION ORDER");
1164 for J in Elab_Order.First .. Elab_Order.Last loop
1165 Set_String (" -- ");
1166 Get_Unit_Name_String (Units.Table (Elab_Order.Table (J)).Uname);
1168 Write_Statement_Buffer;
1171 WBI (" -- END ELABORATION ORDER");
1172 end Gen_Elab_Order_Ada;
1174 ----------------------
1175 -- Gen_Elab_Order_C --
1176 ----------------------
1178 procedure Gen_Elab_Order_C is
1181 WBI ("/* BEGIN ELABORATION ORDER");
1183 for J in Elab_Order.First .. Elab_Order.Last loop
1184 Get_Unit_Name_String (Units.Table (Elab_Order.Table (J)).Uname);
1186 Write_Statement_Buffer;
1189 WBI (" END ELABORATION ORDER */");
1190 end Gen_Elab_Order_C;
1192 -----------------------------
1193 -- Gen_Exception_Table_Ada --
1194 -----------------------------
1196 procedure Gen_Exception_Table_Ada is
1198 Last : ALI_Id := No_ALI_Id;
1201 if not Zero_Cost_Exceptions_Specified then
1206 -- The code we generate looks like
1208 -- procedure SDP_Table_Build
1209 -- (SDP_Addresses : System.Address;
1210 -- SDP_Count : Natural;
1211 -- Elab_Addresses : System.Address;
1212 -- Elab_Addr_Count : Natural);
1213 -- pragma Import (C, SDP_Table_Build, "__gnat_SDP_Table_Build");
1215 -- ST : aliased constant array (1 .. nnn) of System.Address := (
1216 -- unit_name_1'UET_Address,
1217 -- unit_name_2'UET_Address,
1219 -- unit_name_3'UET_Address,
1221 -- EA : aliased constant array (1 .. eee) of System.Address := (
1222 -- adainit'Code_Address,
1223 -- adafinal'Code_Address,
1224 -- unit_name'elab[spec|body]'Code_Address,
1225 -- unit_name'elab[spec|body]'Code_Address,
1226 -- unit_name'elab[spec|body]'Code_Address,
1227 -- unit_name'elab[spec|body]'Code_Address);
1230 -- SDP_Table_Build (ST'Address, nnn, EA'Address, eee);
1233 for A in ALIs.First .. ALIs.Last loop
1234 if not ALIs.Table (A).Interface
1235 and then ALIs.Table (A).Unit_Exception_Table
1244 -- Happens with "gnatmake -a -f -gnatL ..."
1251 WBI (" procedure SDP_Table_Build");
1252 WBI (" (SDP_Addresses : System.Address;");
1253 WBI (" SDP_Count : Natural;");
1254 WBI (" Elab_Addresses : System.Address;");
1255 WBI (" Elab_Addr_Count : Natural);");
1257 "pragma Import (C, SDP_Table_Build, ""__gnat_SDP_Table_Build"");");
1260 Set_String (" ST : aliased constant array (1 .. ");
1262 Set_String (") of System.Address := (");
1265 Set_String ("1 => A1);");
1266 Write_Statement_Buffer;
1269 Write_Statement_Buffer;
1271 for A in ALIs.First .. ALIs.Last loop
1272 if not ALIs.Table (A).Interface
1273 and then ALIs.Table (A).Unit_Exception_Table
1275 Get_Decoded_Name_String_With_Brackets
1276 (Units.Table (ALIs.Table (A).First_Unit).Uname);
1277 Set_Casing (Mixed_Case);
1279 Set_String (Name_Buffer (1 .. Name_Len - 2));
1280 Set_String ("'UET_Address");
1288 Write_Statement_Buffer;
1294 Set_String (" EA : aliased constant array (1 .. ");
1295 Set_Int (Num_Elab_Calls + 2);
1296 Set_String (") of System.Address := (");
1297 Write_Statement_Buffer;
1298 WBI (" " & Ada_Init_Name.all & "'Code_Address,");
1300 -- If compiling for the JVM, we directly reference Adafinal because
1301 -- we don't import it via Do_Finalize (see Gen_Output_File_Ada).
1303 if not Cumulative_Restrictions.Set (No_Finalization) then
1304 if Hostparm.Java_VM then
1306 (" System.Standard_Library.Adafinal'Code_Address");
1309 (" Do_Finalize'Code_Address");
1313 for E in Elab_Order.First .. Elab_Order.Last loop
1314 Get_Decoded_Name_String_With_Brackets
1315 (Units.Table (Elab_Order.Table (E)).Uname);
1317 if Units.Table (Elab_Order.Table (E)).No_Elab then
1322 Write_Statement_Buffer;
1325 if Name_Buffer (Name_Len) = 's' then
1326 Name_Buffer (Name_Len - 1 .. Name_Len + 21) :=
1327 "'elab_spec'code_address";
1329 Name_Buffer (Name_Len - 1 .. Name_Len + 21) :=
1330 "'elab_body'code_address";
1333 Name_Len := Name_Len + 21;
1334 Set_Casing (Units.Table (Elab_Order.Table (E)).Icasing);
1340 Write_Statement_Buffer;
1345 Set_String (" SDP_Table_Build (ST'Address, ");
1347 Set_String (", EA'Address, ");
1348 Set_Int (Num_Elab_Calls + 2);
1350 Write_Statement_Buffer;
1351 end Gen_Exception_Table_Ada;
1353 ---------------------------
1354 -- Gen_Exception_Table_C --
1355 ---------------------------
1357 procedure Gen_Exception_Table_C is
1362 if not Zero_Cost_Exceptions_Specified then
1366 -- The code we generate looks like
1368 -- extern void *__gnat_unitname1__SDP;
1369 -- extern void *__gnat_unitname2__SDP;
1372 -- void **st[nnn] = {
1373 -- &__gnat_unitname1__SDP,
1374 -- &__gnat_unitname2__SDP,
1376 -- &__gnat_unitnamen__SDP};
1378 -- extern void unitname1__elabb ();
1379 -- extern void unitname2__elabb ();
1382 -- void (*ea[eee]) () = {
1385 -- unitname1___elab[b,s],
1386 -- unitname2___elab[b,s],
1388 -- unitnamen___elab[b,s]};
1390 -- __gnat_SDP_Table_Build (&st, nnn, &ea, eee);
1393 for A in ALIs.First .. ALIs.Last loop
1394 if not ALIs.Table (A).Interface
1395 and then ALIs.Table (A).Unit_Exception_Table
1399 Set_String (" extern void *__gnat_");
1400 Get_Name_String (Units.Table (ALIs.Table (A).First_Unit).Uname);
1402 Set_String ("__SDP");
1404 Write_Statement_Buffer;
1410 -- Happens with "gnatmake -a -f -gnatL ..."
1417 Set_String (" void **st[");
1419 Set_String ("] = {");
1420 Write_Statement_Buffer;
1423 for A in ALIs.First .. ALIs.Last loop
1424 if not ALIs.Table (A).Interface
1425 and then ALIs.Table (A).Unit_Exception_Table
1429 Set_String (" &__gnat_");
1430 Get_Name_String (Units.Table (ALIs.Table (A).First_Unit).Uname);
1432 Set_String ("__SDP");
1440 Write_Statement_Buffer;
1445 for E in Elab_Order.First .. Elab_Order.Last loop
1446 Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
1448 if Units.Table (Elab_Order.Table (E)).No_Elab then
1452 Set_String (" extern void ");
1454 Set_String ("___elab");
1455 Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body
1456 Set_String (" ();");
1457 Write_Statement_Buffer;
1462 Set_String (" void (*ea[");
1463 Set_Int (Num_Elab_Calls + 2);
1464 Set_String ("]) () = {");
1465 Write_Statement_Buffer;
1467 WBI (" " & Ada_Init_Name.all & ",");
1469 if not Cumulative_Restrictions.Set (No_Finalization) then
1470 Set_String (" system__standard_library__adafinal");
1473 for E in Elab_Order.First .. Elab_Order.Last loop
1474 Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
1476 if Units.Table (Elab_Order.Table (E)).No_Elab then
1481 Write_Statement_Buffer;
1484 Set_String ("___elab");
1485 Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body
1490 Write_Statement_Buffer;
1494 Set_String (" __gnat_SDP_Table_Build (&st, ");
1496 Set_String (", ea, ");
1497 Set_Int (Num_Elab_Calls + 2);
1499 Write_Statement_Buffer;
1500 end Gen_Exception_Table_C;
1506 procedure Gen_Main_Ada is
1510 if Exit_Status_Supported_On_Target then
1511 Set_String (" function ");
1513 Set_String (" procedure ");
1516 Set_String (Get_Main_Name);
1518 if Command_Line_Args_On_Target then
1519 Write_Statement_Buffer;
1520 WBI (" (argc : Integer;");
1521 WBI (" argv : System.Address;");
1522 WBI (" envp : System.Address)");
1524 if Exit_Status_Supported_On_Target then
1525 WBI (" return Integer");
1531 if Exit_Status_Supported_On_Target then
1532 Set_String (" return Integer is");
1537 Write_Statement_Buffer;
1540 -- Initialize and Finalize
1542 if not Cumulative_Restrictions.Set (No_Finalization) then
1543 WBI (" procedure initialize;");
1544 WBI (" pragma Import (C, initialize, ""__gnat_initialize"");");
1546 WBI (" procedure finalize;");
1547 WBI (" pragma Import (C, finalize, ""__gnat_finalize"");");
1551 -- Deal with declarations for main program case
1553 if not No_Main_Subprogram then
1555 -- To call the main program, we declare it using a pragma Import
1556 -- Ada with the right link name.
1558 -- It might seem more obvious to "with" the main program, and call
1559 -- it in the normal Ada manner. We do not do this for three reasons:
1561 -- 1. It is more efficient not to recompile the main program
1562 -- 2. We are not entitled to assume the source is accessible
1563 -- 3. We don't know what options to use to compile it
1565 -- It is really reason 3 that is most critical (indeed we used
1566 -- to generate the "with", but several regression tests failed).
1570 if ALIs.Table (ALIs.First).Main_Program = Func then
1571 WBI (" Result : Integer;");
1573 WBI (" function Ada_Main_Program return Integer;");
1576 WBI (" procedure Ada_Main_Program;");
1579 Set_String (" pragma Import (Ada, Ada_Main_Program, """);
1580 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
1581 Set_Main_Program_Name;
1582 Set_String (""");");
1584 Write_Statement_Buffer;
1588 -- Generate a reference to Ada_Main_Program_Name. This symbol is
1589 -- not referenced elsewhere in the generated program, but is needed
1590 -- by the debugger (that's why it is generated in the first place).
1591 -- The reference stops Ada_Main_Program_Name from being optimized
1592 -- away by smart linkers, such as the AiX linker.
1594 if Bind_Main_Program then
1596 (" Ensure_Reference : System.Address := " &
1597 "Ada_Main_Program_Name'Address;");
1603 -- Acquire command line arguments if present on target
1605 if Command_Line_Args_On_Target then
1606 WBI (" gnat_argc := argc;");
1607 WBI (" gnat_argv := argv;");
1608 WBI (" gnat_envp := envp;");
1611 -- If configurable run time and no command line args, then nothing
1612 -- needs to be done since the gnat_argc/argv/envp variables are
1613 -- suppressed in this case.
1615 elsif Configurable_Run_Time_On_Target then
1618 -- Otherwise set dummy values (to be filled in by some other unit?)
1621 WBI (" gnat_argc := 0;");
1622 WBI (" gnat_argv := System.Null_Address;");
1623 WBI (" gnat_envp := System.Null_Address;");
1626 if not Cumulative_Restrictions.Set (No_Finalization) then
1627 WBI (" Initialize;");
1630 WBI (" " & Ada_Init_Name.all & ";");
1632 if not No_Main_Subprogram then
1633 WBI (" Break_Start;");
1635 if ALIs.Table (ALIs.First).Main_Program = Proc then
1636 WBI (" Ada_Main_Program;");
1638 WBI (" Result := Ada_Main_Program;");
1642 -- Adafinal call is skipped if no finalization
1644 if not Cumulative_Restrictions.Set (No_Finalization) then
1646 -- If compiling for the JVM, we directly call Adafinal because
1647 -- we don't import it via Do_Finalize (see Gen_Output_File_Ada).
1649 if Hostparm.Java_VM then
1650 WBI (" System.Standard_Library.Adafinal;");
1652 WBI (" Do_Finalize;");
1656 -- Finalize is only called if we have a run time
1658 if not Cumulative_Restrictions.Set (No_Finalization) then
1664 if Exit_Status_Supported_On_Target then
1665 if No_Main_Subprogram
1666 or else ALIs.Table (ALIs.First).Main_Program = Proc
1668 WBI (" return (gnat_exit_status);");
1670 WBI (" return (Result);");
1681 procedure Gen_Main_C is
1683 if Exit_Status_Supported_On_Target then
1684 Set_String ("int ");
1686 Set_String ("void ");
1689 Set_String (Get_Main_Name);
1691 -- Generate command line args in prototype if present on target
1693 if Command_Line_Args_On_Target then
1694 Write_Statement_Buffer (" (int argc, char **argv, char **envp)");
1696 -- Case of no command line arguments on target
1699 Write_Statement_Buffer (" ()");
1704 -- Generate a reference to __gnat_ada_main_program_name. This symbol
1705 -- is not referenced elsewhere in the generated program, but is
1706 -- needed by the debugger (that's why it is generated in the first
1707 -- place). The reference stops Ada_Main_Program_Name from being
1708 -- optimized away by smart linkers, such as the AiX linker.
1710 if Bind_Main_Program then
1711 WBI (" char *ensure_reference __attribute__ ((__unused__)) = " &
1712 "__gnat_ada_main_program_name;");
1716 -- If main program is a function, generate result variable
1718 if ALIs.Table (ALIs.First).Main_Program = Func then
1719 WBI (" int result;");
1722 -- Set command line argument values from parameters if command line
1723 -- arguments are present on target
1725 if Command_Line_Args_On_Target then
1726 WBI (" gnat_argc = argc;");
1727 WBI (" gnat_argv = argv;");
1728 WBI (" gnat_envp = envp;");
1731 -- If configurable run-time, then nothing to do, since in this case
1732 -- the gnat_argc/argv/envp variables are entirely suppressed.
1734 elsif Configurable_Run_Time_On_Target then
1737 -- if no command line arguments on target, set dummy values
1740 WBI (" int result;");
1741 WBI (" gnat_argc = 0;");
1742 WBI (" gnat_argv = 0;");
1743 WBI (" gnat_envp = 0;");
1746 -- The __gnat_initialize routine is used only if we have a run-time
1748 if not Suppress_Standard_Library_On_Target then
1750 (" __gnat_initialize ();");
1753 WBI (" " & Ada_Init_Name.all & " ();");
1755 if not No_Main_Subprogram then
1756 WBI (" __gnat_break_start ();");
1759 -- Output main program name
1761 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
1763 -- Main program is procedure case
1765 if ALIs.Table (ALIs.First).Main_Program = Proc then
1767 Set_Main_Program_Name;
1768 Set_String (" ();");
1769 Write_Statement_Buffer;
1771 -- Main program is function case
1773 else -- ALIs.Table (ALIs_First).Main_Program = Func
1774 Set_String (" result = ");
1775 Set_Main_Program_Name;
1776 Set_String (" ();");
1777 Write_Statement_Buffer;
1782 -- Call adafinal if finalization active
1784 if not Cumulative_Restrictions.Set (No_Finalization) then
1786 WBI (" system__standard_library__adafinal ();");
1789 -- The finalize routine is used only if we have a run-time
1791 if not Suppress_Standard_Library_On_Target then
1792 WBI (" __gnat_finalize ();");
1795 -- Case of main program is a function, so the value it returns
1796 -- is the exit status in this case.
1798 if ALIs.Table (ALIs.First).Main_Program = Func then
1799 if Exit_Status_Supported_On_Target then
1801 -- VMS must use Posix exit routine in order to get the effect
1802 -- of a Unix compatible setting of the program exit status.
1803 -- For all other systems, we use the standard exit routine.
1805 if OpenVMS_On_Target then
1806 WBI (" __posix_exit (result);");
1808 WBI (" exit (result);");
1812 -- Case of main program is a procedure, in which case the exit
1813 -- status is whatever was set by a Set_Exit call most recently
1816 if Exit_Status_Supported_On_Target then
1818 -- VMS must use Posix exit routine in order to get the effect
1819 -- of a Unix compatible setting of the program exit status.
1820 -- For all other systems, we use the standard exit routine.
1822 if OpenVMS_On_Target then
1823 WBI (" __posix_exit (gnat_exit_status);");
1825 WBI (" exit (gnat_exit_status);");
1833 ------------------------------
1834 -- Gen_Object_Files_Options --
1835 ------------------------------
1837 procedure Gen_Object_Files_Options is
1839 -- This keeps track of the position in the sorted set of entries
1840 -- in the Linker_Options table of where the first entry from an
1841 -- internal file appears.
1843 procedure Write_Linker_Option;
1844 -- Write binder info linker option.
1846 -------------------------
1847 -- Write_Linker_Option --
1848 -------------------------
1850 procedure Write_Linker_Option is
1855 -- Loop through string, breaking at null's
1858 while Start < Name_Len loop
1860 -- Find null ending this section
1863 while Name_Buffer (Stop) /= ASCII.NUL
1864 and then Stop <= Name_Len loop
1868 -- Process section if non-null
1870 if Stop > Start then
1871 if Output_Linker_Option_List then
1872 Write_Str (Name_Buffer (Start .. Stop - 1));
1876 (" -- ", "", Name_Buffer (Start .. Stop - 1));
1881 end Write_Linker_Option;
1883 -- Start of processing for Gen_Object_Files_Options
1887 Write_Info_Ada_C ("-- ", "/* ", " BEGIN Object file/option list");
1889 for E in Elab_Order.First .. Elab_Order.Last loop
1891 -- If not spec that has an associated body, then generate a
1892 -- comment giving the name of the corresponding object file.
1894 if (not Units.Table (Elab_Order.Table (E)).Interface)
1895 and then Units.Table (Elab_Order.Table (E)).Utype /= Is_Spec
1899 (Units.Table (Elab_Order.Table (E)).My_ALI).Ofile_Full_Name);
1901 -- If the presence of an object file is necessary or if it
1902 -- exists, then use it.
1904 if not Hostparm.Exclude_Missing_Objects
1905 or else GNAT.OS_Lib.Is_Regular_File (Name_Buffer (1 .. Name_Len))
1907 Write_Info_Ada_C (" -- ", "", Name_Buffer (1 .. Name_Len));
1909 if Output_Object_List then
1910 Write_Str (Name_Buffer (1 .. Name_Len));
1914 -- Don't link with the shared library on VMS if an internal
1915 -- filename object is seen. Multiply defined symbols will
1919 and then Is_Internal_File_Name
1921 (Units.Table (Elab_Order.Table (E)).My_ALI).Sfile)
1923 -- Special case for g-trasym.obj, which is not included
1926 Get_Name_String (ALIs.Table
1927 (Units.Table (Elab_Order.Table (E)).My_ALI).Sfile);
1929 if Name_Buffer (1 .. 8) /= "g-trasym" then
1930 Opt.Shared_Libgnat := False;
1937 -- Add a "-Ldir" for each directory in the object path
1939 for J in 1 .. Nb_Dir_In_Obj_Search_Path loop
1941 Dir : constant String_Ptr := Dir_In_Obj_Search_Path (J);
1944 Add_Str_To_Name_Buffer ("-L");
1945 Add_Str_To_Name_Buffer (Dir.all);
1946 Write_Linker_Option;
1950 -- Sort linker options
1952 -- This sort accomplishes two important purposes:
1954 -- a) All application files are sorted to the front, and all
1955 -- GNAT internal files are sorted to the end. This results
1956 -- in a well defined dividing line between the two sets of
1957 -- files, for the purpose of inserting certain standard
1958 -- library references into the linker arguments list.
1960 -- b) Given two different units, we sort the linker options so
1961 -- that those from a unit earlier in the elaboration order
1962 -- comes later in the list. This is a heuristic designed
1963 -- to create a more friendly order of linker options when
1964 -- the operations appear in separate units. The idea is that
1965 -- if unit A must be elaborated before unit B, then it is
1966 -- more likely that B references libraries included by A,
1967 -- than vice versa, so we want the libraries included by
1968 -- A to come after the libraries included by B.
1970 -- These two criteria are implemented by function Lt_Linker_Option.
1971 -- Note that a special case of b) is that specs are elaborated before
1972 -- bodies, so linker options from specs come after linker options
1973 -- for bodies, and again, the assumption is that libraries used by
1974 -- the body are more likely to reference libraries used by the spec,
1978 (Linker_Options.Last,
1979 Move_Linker_Option'Access,
1980 Lt_Linker_Option'Access);
1982 -- Write user linker options, i.e. the set of linker options that
1983 -- come from all files other than GNAT internal files, Lgnat is
1984 -- left set to point to the first entry from a GNAT internal file,
1985 -- or past the end of the entriers if there are no internal files.
1987 Lgnat := Linker_Options.Last + 1;
1989 for J in 1 .. Linker_Options.Last loop
1990 if not Linker_Options.Table (J).Internal_File then
1991 Get_Name_String (Linker_Options.Table (J).Name);
1992 Write_Linker_Option;
1999 -- Now we insert standard linker options that must appear after the
2000 -- entries from user files, and before the entries from GNAT run-time
2001 -- files. The reason for this decision is that libraries referenced
2002 -- by internal routines may reference these standard library entries.
2004 if not Opt.No_Stdlib then
2007 if Opt.Shared_Libgnat then
2008 Add_Str_To_Name_Buffer ("-shared");
2010 Add_Str_To_Name_Buffer ("-static");
2013 -- Write directly to avoid -K output (why???)
2015 Write_Info_Ada_C (" -- ", "", Name_Buffer (1 .. Name_Len));
2017 if With_DECGNAT then
2019 Add_Str_To_Name_Buffer ("-ldecgnat");
2020 Write_Linker_Option;
2026 if Opt.Shared_Libgnat then
2027 Add_Str_To_Name_Buffer (Shared_Lib ("gnarl"));
2029 Add_Str_To_Name_Buffer ("-lgnarl");
2032 Write_Linker_Option;
2037 if Opt.Shared_Libgnat then
2038 Add_Str_To_Name_Buffer (Shared_Lib ("gnat"));
2040 Add_Str_To_Name_Buffer ("-lgnat");
2043 Write_Linker_Option;
2046 -- Write linker options from all internal files
2048 for J in Lgnat .. Linker_Options.Last loop
2049 Get_Name_String (Linker_Options.Table (J).Name);
2050 Write_Linker_Option;
2053 if Ada_Bind_File then
2054 WBI ("-- END Object file/option list ");
2056 WBI (" END Object file/option list */");
2058 end Gen_Object_Files_Options;
2060 ---------------------
2061 -- Gen_Output_File --
2062 ---------------------
2064 procedure Gen_Output_File (Filename : String) is
2065 Is_Public_Version : constant Boolean := Get_Gnat_Build_Type = Public;
2066 Is_GAP_Version : constant Boolean := Get_Gnat_Build_Type = GAP;
2069 -- Acquire settings for Interrupt_State pragmas
2071 Set_IS_Pragma_Table;
2073 -- Override Ada_Bind_File and Bind_Main_Program for Java since
2074 -- JGNAT only supports Ada code, and the main program is already
2075 -- generated by the compiler.
2077 if Hostparm.Java_VM then
2078 Ada_Bind_File := True;
2079 Bind_Main_Program := False;
2082 -- Override time slice value if -T switch is set
2084 if Time_Slice_Set then
2085 ALIs.Table (ALIs.First).Time_Slice_Value := Opt.Time_Slice_Value;
2088 -- Count number of elaboration calls
2090 for E in Elab_Order.First .. Elab_Order.Last loop
2091 if Units.Table (Elab_Order.Table (E)).No_Elab then
2094 Num_Elab_Calls := Num_Elab_Calls + 1;
2098 -- Get the time stamp of the former bind for public version warning
2100 if Is_Public_Version or Is_GAP_Version then
2101 Record_Time_From_Last_Bind;
2104 -- Generate output file in appropriate language
2106 if Ada_Bind_File then
2107 Gen_Output_File_Ada (Filename);
2109 Gen_Output_File_C (Filename);
2112 -- Periodically issue a warning when the public version is used on
2115 if Is_Public_Version then
2116 Public_Version_Warning;
2118 end Gen_Output_File;
2120 -------------------------
2121 -- Gen_Output_File_Ada --
2122 -------------------------
2124 procedure Gen_Output_File_Ada (Filename : String) is
2127 -- Name of generated bind file (spec)
2130 -- Name of generated bind file (body)
2132 Ada_Main : constant String := Get_Ada_Main_Name;
2133 -- Name to be used for generated Ada main program. See the body of
2134 -- function Get_Ada_Main_Name for details on the form of the name.
2137 -- Create spec first
2139 Create_Binder_Output (Filename, 's', Bfiles);
2141 -- If we are operating in Restrictions (No_Exception_Handlers) mode,
2142 -- then we need to make sure that the binder program is compiled with
2143 -- the same restriction, so that no exception tables are generated.
2145 if Cumulative_Restrictions.Set (No_Exception_Handlers) then
2146 WBI ("pragma Restrictions (No_Exception_Handlers);");
2149 -- Generate with of System so we can reference System.Address
2151 WBI ("with System;");
2153 -- Generate with of System.Initialize_Scalars if active
2155 if Initialize_Scalars_Used then
2156 WBI ("with System.Scalar_Values;");
2159 -- Generate with of System.Secondary_Stack if active
2161 if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then
2162 WBI ("with System.Secondary_Stack;");
2165 Resolve_Binder_Options;
2167 if not Suppress_Standard_Library_On_Target then
2169 -- Usually, adafinal is called using a pragma Import C. Since
2170 -- Import C doesn't have the same semantics for JGNAT, we use
2173 if Hostparm.Java_VM then
2174 WBI ("with System.Standard_Library;");
2178 WBI ("package " & Ada_Main & " is");
2179 WBI (" pragma Warnings (Off);");
2181 -- Main program case
2183 if Bind_Main_Program then
2185 -- Generate argc/argv stuff unless suppressed
2187 if Command_Line_Args_On_Target
2188 or not Configurable_Run_Time_On_Target
2191 WBI (" gnat_argc : Integer;");
2192 WBI (" gnat_argv : System.Address;");
2193 WBI (" gnat_envp : System.Address;");
2195 -- If the standard library is not suppressed, these variables are
2196 -- in the runtime data area for easy access from the runtime
2198 if not Suppress_Standard_Library_On_Target then
2200 WBI (" pragma Import (C, gnat_argc);");
2201 WBI (" pragma Import (C, gnat_argv);");
2202 WBI (" pragma Import (C, gnat_envp);");
2206 -- Define exit status. Again in normal mode, this is in the
2207 -- run-time library, and is initialized there, but in the
2208 -- configurable runtime case, the variable is declared and
2209 -- initialized in this file.
2213 if Configurable_Run_Time_Mode then
2214 if Exit_Status_Supported_On_Target then
2215 WBI (" gnat_exit_status : Integer := 0;");
2218 WBI (" gnat_exit_status : Integer;");
2219 WBI (" pragma Import (C, gnat_exit_status);");
2223 -- Generate the GNAT_Version and Ada_Main_Program_Name info only for
2224 -- the main program. Otherwise, it can lead under some circumstances
2225 -- to a symbol duplication during the link (for instance when a
2226 -- C program uses 2 Ada libraries)
2228 if Bind_Main_Program then
2230 WBI (" GNAT_Version : constant String :=");
2231 WBI (" ""GNAT Version: " &
2232 Gnat_Version_String & """;");
2233 WBI (" pragma Export (C, GNAT_Version, ""__gnat_version"");");
2236 Set_String (" Ada_Main_Program_Name : constant String := """);
2237 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
2238 Set_Main_Program_Name;
2239 Set_String (""" & Ascii.NUL;");
2240 Write_Statement_Buffer;
2243 (" pragma Export (C, Ada_Main_Program_Name, " &
2244 """__gnat_ada_main_program_name"");");
2247 -- No need to generate a finalization routine if finalization
2248 -- is restricted, since there is nothing to do in this case.
2250 if not Cumulative_Restrictions.Set (No_Finalization) then
2252 WBI (" procedure " & Ada_Final_Name.all & ";");
2253 WBI (" pragma Export (C, " & Ada_Final_Name.all & ", """ &
2254 Ada_Final_Name.all & """);");
2258 WBI (" procedure " & Ada_Init_Name.all & ";");
2259 WBI (" pragma Export (C, " & Ada_Init_Name.all & ", """ &
2260 Ada_Init_Name.all & """);");
2262 if Bind_Main_Program then
2264 -- If we have the standard library, then Break_Start is defined
2265 -- there, but when the standard library is suppressed, Break_Start
2269 WBI (" procedure Break_Start;");
2271 if Suppress_Standard_Library_On_Target then
2272 WBI (" pragma Export (C, Break_Start, ""__gnat_break_start"");");
2274 WBI (" pragma Import (C, Break_Start, ""__gnat_break_start"");");
2279 if Exit_Status_Supported_On_Target then
2280 Set_String (" function ");
2282 Set_String (" procedure ");
2285 Set_String (Get_Main_Name);
2287 -- Generate argument list if present
2289 if Command_Line_Args_On_Target then
2290 Write_Statement_Buffer;
2291 WBI (" (argc : Integer;");
2292 WBI (" argv : System.Address;");
2294 (" envp : System.Address)");
2296 if Exit_Status_Supported_On_Target then
2297 Write_Statement_Buffer;
2298 WBI (" return Integer;");
2300 Write_Statement_Buffer (";");
2304 if Exit_Status_Supported_On_Target then
2305 Write_Statement_Buffer (" return Integer;");
2307 Write_Statement_Buffer (";");
2311 WBI (" pragma Export (C, " & Get_Main_Name & ", """ &
2312 Get_Main_Name & """);");
2321 WBI ("end " & Ada_Main & ";");
2322 Close_Binder_Output;
2324 -- Prepare to write body
2326 Create_Binder_Output (Filename, 'b', Bfileb);
2328 -- Output Source_File_Name pragmas which look like
2330 -- pragma Source_File_Name (Ada_Main, Spec_File_Name => "sss");
2331 -- pragma Source_File_Name (Ada_Main, Body_File_Name => "bbb");
2333 -- where sss/bbb are the spec/body file names respectively
2335 Get_Name_String (Bfiles);
2336 Name_Buffer (Name_Len + 1 .. Name_Len + 3) := """);";
2338 WBI ("pragma Source_File_Name (" &
2340 ", Spec_File_Name => """ &
2341 Name_Buffer (1 .. Name_Len + 3));
2343 Get_Name_String (Bfileb);
2344 Name_Buffer (Name_Len + 1 .. Name_Len + 3) := """);";
2346 WBI ("pragma Source_File_Name (" &
2348 ", Body_File_Name => """ &
2349 Name_Buffer (1 .. Name_Len + 3));
2352 WBI ("package body " & Ada_Main & " is");
2353 WBI (" pragma Warnings (Off);");
2355 -- Import the finalization procedure only if finalization active
2357 if not Cumulative_Restrictions.Set (No_Finalization) then
2359 -- In the Java case, pragma Import C cannot be used, so the
2360 -- standard Ada constructs will be used instead.
2362 if not Hostparm.Java_VM then
2364 WBI (" procedure Do_Finalize;");
2366 (" pragma Import (C, Do_Finalize, " &
2367 """system__standard_library__adafinal"");");
2374 -- No need to generate a finalization routine if no finalization
2376 if not Cumulative_Restrictions.Set (No_Finalization) then
2380 if Bind_Main_Program then
2382 -- When suppressing the standard library then generate dummy body
2385 if Suppress_Standard_Library_On_Target then
2387 WBI (" procedure Break_Start is");
2396 -- Output object file list and the Ada body is complete
2398 Gen_Object_Files_Options;
2401 WBI ("end " & Ada_Main & ";");
2403 Close_Binder_Output;
2404 end Gen_Output_File_Ada;
2406 -----------------------
2407 -- Gen_Output_File_C --
2408 -----------------------
2410 procedure Gen_Output_File_C (Filename : String) is
2413 -- Name of generated bind file
2416 Create_Binder_Output (Filename, 'c', Bfile);
2418 Resolve_Binder_Options;
2420 WBI ("extern void __gnat_set_globals");
2421 WBI (" (int, int, char, char, char, char,");
2422 WBI (" const char *, const char *,");
2423 WBI (" int, int, int, int);");
2424 WBI ("extern void " & Ada_Final_Name.all & " (void);");
2425 WBI ("extern void " & Ada_Init_Name.all & " (void);");
2426 WBI ("extern void system__standard_library__adafinal (void);");
2428 if not No_Main_Subprogram then
2429 Set_String ("extern ");
2431 if Exit_Status_Supported_On_Target then
2434 Set_String ("void");
2437 Set_String (" main ");
2439 if Command_Line_Args_On_Target then
2440 Write_Statement_Buffer ("(int, char **, char **);");
2442 Write_Statement_Buffer ("(void);");
2445 if OpenVMS_On_Target then
2446 WBI ("extern void __posix_exit (int);");
2448 WBI ("extern void exit (int);");
2451 WBI ("extern void __gnat_break_start (void);");
2452 Set_String ("extern ");
2454 if ALIs.Table (ALIs.First).Main_Program = Proc then
2455 Set_String ("void ");
2457 Set_String ("int ");
2460 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
2461 Set_Main_Program_Name;
2462 Set_String (" (void);");
2463 Write_Statement_Buffer;
2466 if not Suppress_Standard_Library_On_Target then
2467 WBI ("extern void __gnat_initialize (void);");
2468 WBI ("extern void __gnat_finalize (void);");
2469 WBI ("extern void __gnat_install_handler (void);");
2476 -- Imported variable used to track elaboration/finalization phase.
2477 -- Used only when we have a runtime.
2479 if not Suppress_Standard_Library_On_Target then
2480 WBI ("extern int __gnat_handler_installed;");
2484 -- Write argv/argc exit status stuff if main program case
2486 if Bind_Main_Program then
2488 -- First deal with argc/argv/envp. In the normal case they
2489 -- are in the run-time library.
2491 if not Configurable_Run_Time_On_Target then
2492 WBI ("extern int gnat_argc;");
2493 WBI ("extern char **gnat_argv;");
2494 WBI ("extern char **gnat_envp;");
2495 WBI ("extern int gnat_exit_status;");
2497 -- If configurable run time and no command line args, then the
2498 -- generation of these variables is entirely suppressed.
2500 elsif not Command_Line_Args_On_Target then
2503 -- Otherwise, in the configurable run-time case they are right in
2507 WBI ("int gnat_argc;");
2508 WBI ("char **gnat_argv;");
2509 WBI ("char **gnat_envp;");
2510 WBI ("int gnat_exit_status = 0;");
2513 -- Similarly deal with exit status
2514 -- are in the run-time library.
2516 if not Configurable_Run_Time_On_Target then
2517 WBI ("extern int gnat_exit_status;");
2519 -- If configurable run time and no exit status on target, then
2520 -- the generation of this variables is entirely suppressed.
2522 elsif not Exit_Status_Supported_On_Target then
2525 -- Otherwise, in the configurable run-time case this variable is
2526 -- right in the binder file, and initialized to zero there.
2529 WBI ("int gnat_exit_status = 0;");
2535 -- When suppressing the standard library, the __gnat_break_start
2536 -- routine (for the debugger to get initial control) is defined in
2539 if Suppress_Standard_Library_On_Target then
2541 WBI ("void __gnat_break_start () {}");
2544 -- Generate the __gnat_version and __gnat_ada_main_program_name info
2545 -- only for the main program. Otherwise, it can lead under some
2546 -- circumstances to a symbol duplication during the link (for instance
2547 -- when a C program uses 2 Ada libraries)
2549 if Bind_Main_Program then
2551 WBI ("char __gnat_version[] = ""GNAT Version: " &
2552 Gnat_Version_String & """;");
2554 Set_String ("char __gnat_ada_main_program_name[] = """);
2555 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
2556 Set_Main_Program_Name;
2558 Write_Statement_Buffer;
2561 -- Generate the adafinal routine. In no runtime mode, this is
2562 -- not needed, since there is no finalization to do.
2564 if not Cumulative_Restrictions.Set (No_Finalization) then
2570 -- Main is only present for Ada main case
2572 if Bind_Main_Program then
2576 -- Generate versions, elaboration order, list of object files
2580 Gen_Object_Files_Options;
2582 -- C binder output is complete
2584 Close_Binder_Output;
2585 end Gen_Output_File_C;
2587 -------------------------------
2588 -- Gen_Restrictions_String_1 --
2589 -------------------------------
2591 procedure Gen_Restrictions_String_1 is
2593 for R in All_Boolean_Restrictions loop
2594 if Cumulative_Restrictions.Set (R) then
2596 elsif Cumulative_Restrictions.Violated (R) then
2602 end Gen_Restrictions_String_1;
2604 -------------------------------
2605 -- Gen_Restrictions_String_2 --
2606 -------------------------------
2608 procedure Gen_Restrictions_String_2 is
2610 for RP in All_Parameter_Restrictions loop
2611 if Cumulative_Restrictions.Set (RP) then
2613 Set_Int (Int (Cumulative_Restrictions.Value (RP)));
2618 if not Cumulative_Restrictions.Violated (RP)
2619 or else RP not in Checked_Parameter_Restrictions
2624 Set_Int (Int (Cumulative_Restrictions.Count (RP)));
2626 if Cumulative_Restrictions.Unknown (RP) then
2631 end Gen_Restrictions_String_2;
2633 ----------------------
2634 -- Gen_Versions_Ada --
2635 ----------------------
2637 -- This routine generates two sets of lines. The first set has the form:
2639 -- unnnnn : constant Integer := 16#hhhhhhhh#;
2641 -- The second set has the form
2643 -- pragma Export (C, unnnnn, unam);
2645 -- for each unit, where unam is the unit name suffixed by either B or
2646 -- S for body or spec, with dots replaced by double underscores, and
2647 -- hhhhhhhh is the version number, and nnnnn is a 5-digits serial number.
2649 procedure Gen_Versions_Ada is
2650 Ubuf : String (1 .. 6) := "u00000";
2652 procedure Increment_Ubuf;
2653 -- Little procedure to increment the serial number
2655 procedure Increment_Ubuf is
2657 for J in reverse Ubuf'Range loop
2658 Ubuf (J) := Character'Succ (Ubuf (J));
2659 exit when Ubuf (J) <= '9';
2664 -- Start of processing for Gen_Versions_Ada
2667 if Bind_For_Library then
2669 -- When building libraries, the version number of each unit can
2670 -- not be computed, since the binder does not know the full list
2671 -- of units. Therefore, the 'Version and 'Body_Version
2672 -- attributes can not supported in this case.
2679 WBI (" type Version_32 is mod 2 ** 32;");
2680 for U in Units.First .. Units.Last loop
2682 WBI (" " & Ubuf & " : constant Version_32 := 16#" &
2683 Units.Table (U).Version & "#;");
2689 for U in Units.First .. Units.Last loop
2691 Set_String (" pragma Export (C, ");
2693 Set_String (", """);
2695 Get_Name_String (Units.Table (U).Uname);
2697 for K in 1 .. Name_Len loop
2698 if Name_Buffer (K) = '.' then
2702 elsif Name_Buffer (K) = '%' then
2706 Set_Char (Name_Buffer (K));
2710 if Name_Buffer (Name_Len) = 's' then
2716 Set_String (""");");
2717 Write_Statement_Buffer;
2720 end Gen_Versions_Ada;
2722 --------------------
2723 -- Gen_Versions_C --
2724 --------------------
2726 -- This routine generates a line of the form:
2728 -- unsigned unam = 0xhhhhhhhh;
2730 -- for each unit, where unam is the unit name suffixed by either B or
2731 -- S for body or spec, with dots replaced by double underscores.
2733 procedure Gen_Versions_C is
2735 if Bind_For_Library then
2737 -- When building libraries, the version number of each unit can
2738 -- not be computed, since the binder does not know the full list
2739 -- of units. Therefore, the 'Version and 'Body_Version
2740 -- attributes can not supported.
2745 for U in Units.First .. Units.Last loop
2746 Set_String ("unsigned ");
2748 Get_Name_String (Units.Table (U).Uname);
2750 for K in 1 .. Name_Len loop
2751 if Name_Buffer (K) = '.' then
2754 elsif Name_Buffer (K) = '%' then
2758 Set_Char (Name_Buffer (K));
2762 if Name_Buffer (Name_Len) = 's' then
2768 Set_String (" = 0x");
2769 Set_String (Units.Table (U).Version);
2771 Write_Statement_Buffer;
2776 -----------------------
2777 -- Get_Ada_Main_Name --
2778 -----------------------
2780 function Get_Ada_Main_Name return String is
2781 Suffix : constant String := "_00";
2782 Name : String (1 .. Opt.Ada_Main_Name.all'Length + Suffix'Length) :=
2783 Opt.Ada_Main_Name.all & Suffix;
2787 -- The main program generated by JGNAT expects a package called
2788 -- ada_<main procedure>.
2790 if Hostparm.Java_VM then
2791 -- Get main program name
2793 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
2797 return "ada_" & Name_Buffer (1 .. Name_Len - 2);
2800 -- This loop tries the following possibilities in order
2806 -- where <Ada_Main> is equal to Opt.Ada_Main_Name. By default,
2807 -- it is set to 'ada_main'.
2809 for J in 0 .. 99 loop
2811 Nlen := Name'Length - Suffix'Length;
2813 Nlen := Name'Length;
2814 Name (Name'Last) := Character'Val (J mod 10 + Character'Pos ('0'));
2815 Name (Name'Last - 1) :=
2816 Character'Val (J / 10 + Character'Pos ('0'));
2819 for K in ALIs.First .. ALIs.Last loop
2820 for L in ALIs.Table (K).First_Unit .. ALIs.Table (K).Last_Unit loop
2822 -- Get unit name, removing %b or %e at end
2824 Get_Name_String (Units.Table (L).Uname);
2825 Name_Len := Name_Len - 2;
2827 if Name_Buffer (1 .. Name_Len) = Name (1 .. Nlen) then
2833 return Name (1 .. Nlen);
2839 -- If we fall through, just use a peculiar unlikely name
2841 return ("Qwertyuiop");
2842 end Get_Ada_Main_Name;
2848 function Get_Main_Name return String is
2850 -- Explicit name given with -M switch
2852 if Bind_Alternate_Main_Name then
2853 return Alternate_Main_Name.all;
2855 -- Case of main program name to be used directly
2857 elsif Use_Ada_Main_Program_Name_On_Target then
2859 -- Get main program name
2861 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
2863 -- If this is a child name, return only the name of the child,
2864 -- since we can't have dots in a nested program name. Note that
2865 -- we do not include the %b at the end of the unit name.
2867 for J in reverse 1 .. Name_Len - 2 loop
2868 if J = 1 or else Name_Buffer (J - 1) = '.' then
2869 return Name_Buffer (J .. Name_Len - 2);
2873 raise Program_Error; -- impossible exit
2875 -- Case where "main" is to be used as default
2882 ----------------------
2883 -- Lt_Linker_Option --
2884 ----------------------
2886 function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean is
2888 -- Sort internal files last
2890 if Linker_Options.Table (Op1).Internal_File
2892 Linker_Options.Table (Op2).Internal_File
2894 -- Note: following test uses False < True
2896 return Linker_Options.Table (Op1).Internal_File
2898 Linker_Options.Table (Op2).Internal_File;
2900 -- If both internal or both non-internal, sort according to the
2901 -- elaboration position. A unit that is elaborated later should
2902 -- come earlier in the linker options list.
2905 return Units.Table (Linker_Options.Table (Op1).Unit).Elab_Position
2907 Units.Table (Linker_Options.Table (Op2).Unit).Elab_Position;
2910 end Lt_Linker_Option;
2912 ------------------------
2913 -- Move_Linker_Option --
2914 ------------------------
2916 procedure Move_Linker_Option (From : Natural; To : Natural) is
2918 Linker_Options.Table (To) := Linker_Options.Table (From);
2919 end Move_Linker_Option;
2921 ----------------------------
2922 -- Public_Version_Warning --
2923 ----------------------------
2925 procedure Public_Version_Warning is
2926 Time : constant Int := Time_From_Last_Bind;
2928 -- Constants to help defining periods
2930 Hour : constant := 60;
2931 Day : constant := 24 * Hour;
2933 Never : constant := Integer'Last;
2934 -- Special value indicating no warnings should be given
2936 -- Constants defining when the warning is issued. Programs with more
2937 -- than Large Units will issue a warning every Period_Large amount of
2938 -- time. Smaller programs will generate a warning every Period_Small
2941 Large : constant := 20;
2942 -- Threshold for considering a program small or large
2944 Period_Large : constant := Day;
2945 -- Periodic warning time for large programs
2947 Period_Small : constant := Never;
2948 -- Periodic warning time for small programs
2953 -- Compute the number of units that are not GNAT internal files
2956 for A in ALIs.First .. ALIs.Last loop
2957 if not Is_Internal_File_Name (ALIs.Table (A).Sfile) then
2958 Nb_Unit := Nb_Unit + 1;
2962 -- Do not emit the message if the last message was emitted in the
2963 -- specified period taking into account the number of units.
2965 pragma Warnings (Off);
2966 -- Turn off warning of constant condition, which may happen here
2967 -- depending on the choice of constants in the above declarations.
2969 if Nb_Unit < Large and then Time <= Period_Small then
2971 elsif Time <= Period_Large then
2975 pragma Warnings (On);
2978 Write_Str ("IMPORTANT NOTICE:");
2980 Write_Str (" This version of GNAT is unsupported"
2981 & " and comes with absolutely no warranty.");
2983 Write_Str (" If you intend to evaluate or use GNAT for building "
2984 & "commercial applications,");
2986 Write_Str (" please consult http://www.gnat.com/ for information");
2988 Write_Str (" on the GNAT Professional product line.");
2991 end Public_Version_Warning;
2993 ----------------------------
2994 -- Resolve_Binder_Options --
2995 ----------------------------
2997 procedure Resolve_Binder_Options is
2999 for E in Elab_Order.First .. Elab_Order.Last loop
3000 Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
3002 -- The procedure of looking for specific packages and setting
3003 -- flags is somewhat dubious, but there isn't a good alternative
3004 -- at the current time ???
3006 if Name_Buffer (1 .. 19) = "system.os_interface" then
3010 if Hostparm.OpenVMS and then Name_Buffer (1 .. 5) = "dec%s" then
3011 With_DECGNAT := True;
3014 end Resolve_Binder_Options;
3020 procedure Set_Char (C : Character) is
3023 Statement_Buffer (Last) := C;
3030 procedure Set_Int (N : Int) is
3042 Statement_Buffer (Last) :=
3043 Character'Val (N mod 10 + Character'Pos ('0'));
3047 -------------------------
3048 -- Set_IS_Pragma_Table --
3049 -------------------------
3051 procedure Set_IS_Pragma_Table is
3053 for F in ALIs.First .. ALIs.Last loop
3054 for K in ALIs.Table (F).First_Interrupt_State ..
3055 ALIs.Table (F).Last_Interrupt_State
3058 Inum : constant Int :=
3059 Interrupt_States.Table (K).Interrupt_Id;
3060 Stat : constant Character :=
3061 Interrupt_States.Table (K).Interrupt_State;
3064 while IS_Pragma_Settings.Last < Inum loop
3065 IS_Pragma_Settings.Append ('n');
3068 IS_Pragma_Settings.Table (Inum) := Stat;
3072 end Set_IS_Pragma_Table;
3074 ---------------------------
3075 -- Set_Main_Program_Name --
3076 ---------------------------
3078 procedure Set_Main_Program_Name is
3080 -- Note that name has %b on the end which we ignore
3082 -- First we output the initial _ada_ since we know that the main
3083 -- program is a library level subprogram.
3085 Set_String ("_ada_");
3087 -- Copy name, changing dots to double underscores
3089 for J in 1 .. Name_Len - 2 loop
3090 if Name_Buffer (J) = '.' then
3093 Set_Char (Name_Buffer (J));
3096 end Set_Main_Program_Name;
3098 ---------------------
3099 -- Set_Name_Buffer --
3100 ---------------------
3102 procedure Set_Name_Buffer is
3104 for J in 1 .. Name_Len loop
3105 Set_Char (Name_Buffer (J));
3107 end Set_Name_Buffer;
3113 procedure Set_String (S : String) is
3115 Statement_Buffer (Last + 1 .. Last + S'Length) := S;
3116 Last := Last + S'Length;
3123 procedure Set_Unit_Name is
3125 for J in 1 .. Name_Len - 2 loop
3126 if Name_Buffer (J) /= '.' then
3127 Set_Char (Name_Buffer (J));
3134 ---------------------
3135 -- Set_Unit_Number --
3136 ---------------------
3138 procedure Set_Unit_Number (U : Unit_Id) is
3139 Num_Units : constant Nat := Nat (Units.Last) - Nat (Unit_Id'First);
3140 Unum : constant Nat := Nat (U) - Nat (Unit_Id'First);
3143 if Num_Units >= 10 and then Unum < 10 then
3147 if Num_Units >= 100 and then Unum < 100 then
3152 end Set_Unit_Number;
3158 procedure Tab_To (N : Natural) is
3165 ----------------------
3166 -- Write_Info_Ada_C --
3167 ----------------------
3169 procedure Write_Info_Ada_C (Ada : String; C : String; Common : String) is
3171 if Ada_Bind_File then
3173 S : String (1 .. Ada'Length + Common'Length);
3175 S (1 .. Ada'Length) := Ada;
3176 S (Ada'Length + 1 .. S'Length) := Common;
3182 S : String (1 .. C'Length + Common'Length);
3184 S (1 .. C'Length) := C;
3185 S (C'Length + 1 .. S'Length) := Common;
3189 end Write_Info_Ada_C;
3191 ----------------------------
3192 -- Write_Statement_Buffer --
3193 ----------------------------
3195 procedure Write_Statement_Buffer is
3197 WBI (Statement_Buffer (1 .. Last));
3199 end Write_Statement_Buffer;
3201 procedure Write_Statement_Buffer (S : String) is
3204 Write_Statement_Buffer;
3205 end Write_Statement_Buffer;