1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2005, 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 Casing; use Casing;
30 with Fname; use Fname;
31 with GNAT.OS_Lib; use GNAT.OS_Lib;
32 with Gnatvsn; use Gnatvsn;
34 with Namet; use Namet;
36 with Osint; use Osint;
37 with Osint.B; use Osint.B;
38 with Output; use Output;
39 with Rident; use Rident;
40 with Table; use Table;
41 with Targparm; use Targparm;
42 with Types; use Types;
44 with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
46 package body Bindgen is
48 Statement_Buffer : String (1 .. 1000);
49 -- Buffer used for constructing output statements
52 -- Last location in Statement_Buffer currently set
54 With_DECGNAT : Boolean := False;
55 -- Flag which indicates whether the program uses the DECGNAT library
56 -- (presence of the unit DEC).
58 With_GNARL : Boolean := False;
59 -- Flag which indicates whether the program uses the GNARL library
60 -- (presence of the unit System.OS_Interface)
62 Num_Elab_Calls : Nat := 0;
63 -- Number of generated calls to elaboration routines
65 ----------------------------------
66 -- Interface_State Pragma Table --
67 ----------------------------------
69 -- This table assembles the interface state pragma information from
70 -- all the units in the partition. Note that Bcheck has already checked
71 -- that the information is consistent across partitions. The entries
72 -- in this table are n/u/r/s for not set/user/runtime/system.
74 package IS_Pragma_Settings is new Table.Table (
75 Table_Component_Type => Character,
76 Table_Index_Type => Int,
79 Table_Increment => 200,
80 Table_Name => "IS_Pragma_Settings");
82 ----------------------
83 -- Run-Time Globals --
84 ----------------------
86 -- This section documents the global variables that are passed to the
87 -- run time from the generated binder file. The call that is made is
88 -- to the routine Set_Globals, which has the following spec:
90 -- procedure Set_Globals
91 -- (Main_Priority : Integer;
92 -- Time_Slice_Value : Integer;
93 -- WC_Encoding : Character;
94 -- Locking_Policy : Character;
95 -- Queuing_Policy : Character;
96 -- Task_Dispatching_Policy : Character;
97 -- Restrictions : System.Address;
98 -- Interrupt_States : System.Address;
99 -- Num_Interrupt_States : Integer;
100 -- Unreserve_All_Interrupts : Integer;
101 -- Exception_Tracebacks : Integer;
102 -- Zero_Cost_Exceptions : Integer;
103 -- Detect_Blocking : 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 -- Detect_Blocking indicates whether pragma Detect_Blocking is
166 -- active or not. A value of zero indicates that the pragma is not
167 -- present, while a value of 1 signals its presence in the
170 -----------------------
171 -- Local Subprograms --
172 -----------------------
174 procedure WBI (Info : String) renames Osint.B.Write_Binder_Info;
175 -- Convenient shorthand used throughout
177 procedure Gen_Adainit_Ada;
178 -- Generates the Adainit procedure (Ada code case)
180 procedure Gen_Adainit_C;
181 -- Generates the Adainit procedure (C code case)
183 procedure Gen_Adafinal_Ada;
184 -- Generate the Adafinal procedure (Ada code case)
186 procedure Gen_Adafinal_C;
187 -- Generate the Adafinal procedure (C code case)
189 procedure Gen_Elab_Calls_Ada;
190 -- Generate sequence of elaboration calls (Ada code case)
192 procedure Gen_Elab_Calls_C;
193 -- Generate sequence of elaboration calls (C code case)
195 procedure Gen_Elab_Order_Ada;
196 -- Generate comments showing elaboration order chosen (Ada case)
198 procedure Gen_Elab_Order_C;
199 -- Generate comments showing elaboration order chosen (C case)
201 procedure Gen_Elab_Defs_C;
202 -- Generate sequence of definitions for elaboration routines (C code case)
204 procedure Gen_Exception_Table_Ada;
205 -- Generate binder exception table (Ada code case). This consists of
206 -- declarations followed by a begin followed by a call. If zero cost
207 -- exceptions are not active, then only the begin is generated.
209 procedure Gen_Exception_Table_C;
210 -- Generate binder exception table (C code case). This has no effect
211 -- if zero cost exceptions are not active, otherwise it generates a
212 -- set of declarations followed by a call.
214 procedure Gen_Main_Ada;
215 -- Generate procedure main (Ada code case)
217 procedure Gen_Main_C;
218 -- Generate main() procedure (C code case)
220 procedure Gen_Object_Files_Options;
221 -- Output comments containing a list of the full names of the object
222 -- files to be linked and the list of linker options supplied by
223 -- Linker_Options pragmas in the source. (C and Ada code case)
225 procedure Gen_Output_File_Ada (Filename : String);
226 -- Generate output file (Ada code case)
228 procedure Gen_Output_File_C (Filename : String);
229 -- Generate output file (C code case)
231 procedure Gen_Restrictions_String_1;
232 -- Generate first restrictions string, which consists of the parameters
233 -- the first R line, as described in lib-writ.ads, with the restrictions
234 -- being those for the entire partition (from Cumulative_Restrictions).
236 procedure Gen_Restrictions_String_2;
237 -- Generate first restrictions string, which consists of the parameters
238 -- the second R line, as described in lib-writ.ads, with the restrictions
239 -- being those for the entire partition (from Cumulative_Restrictions).
241 procedure Gen_Versions_Ada;
242 -- Output series of definitions for unit versions (Ada code case)
244 procedure Gen_Versions_C;
245 -- Output series of definitions for unit versions (C code case)
247 function Get_Ada_Main_Name return String;
248 -- This function is used in the Ada main output case to compute a usable
249 -- name for the generated main program. The normal main program name is
250 -- Ada_Main, but this won't work if the user has a unit with this name.
251 -- This function tries Ada_Main first, and if there is such a clash, then
252 -- it tries Ada_Name_01, Ada_Name_02 ... Ada_Name_99 in sequence.
254 function Get_Main_Name return String;
255 -- This function is used in the Ada main output case to compute the
256 -- correct external main program. It is "main" by default, unless the
257 -- flag Use_Ada_Main_Program_Name_On_Target is set, in which case it
258 -- is the name of the Ada main name without the "_ada". This default
259 -- can be overridden explicitly using the -Mname binder switch.
261 function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean;
262 -- Compare linker options, when sorting, first according to
263 -- Is_Internal_File (internal files come later) and then by
264 -- elaboration order position (latest to earliest).
266 procedure Move_Linker_Option (From : Natural; To : Natural);
267 -- Move routine for sorting linker options
269 procedure Public_Version_Warning;
270 -- Emit a warning concerning the use of the Public version under
271 -- certain circumstances. See details in body.
273 procedure Resolve_Binder_Options;
274 -- Set the value of With_GNARL and With_DECGNAT. The latter only on VMS
275 -- since it tests for a package named "dec" which might cause a conflict
276 -- on non-VMS systems.
278 procedure Set_Char (C : Character);
279 -- Set given character in Statement_Buffer at the Last + 1 position
280 -- and increment Last by one to reflect the stored character.
282 procedure Set_EA_Last;
283 -- Output the number of elements in array EA
285 procedure Set_Int (N : Int);
286 -- Set given value in decimal in Statement_Buffer with no spaces
287 -- starting at the Last + 1 position, and updating Last past the value.
288 -- A minus sign is output for a negative value.
290 procedure Set_IS_Pragma_Table;
291 -- Initializes contents of IS_Pragma_Settings table from ALI table
293 procedure Set_Main_Program_Name;
294 -- Given the main program name in Name_Buffer (length in Name_Len)
295 -- generate the name of the routine to be used in the call. The name
296 -- is generated starting at Last + 1, and Last is updated past it.
298 procedure Set_Name_Buffer;
299 -- Set the value stored in positions 1 .. Name_Len of the Name_Buffer.
301 procedure Set_String (S : String);
302 -- Sets characters of given string in Statement_Buffer, starting at the
303 -- Last + 1 position, and updating last past the string value.
305 procedure Set_Unit_Name;
306 -- Given a unit name in the Name_Buffer, copies it to Statement_Buffer,
307 -- starting at the Last + 1 position, and updating last past the value.
308 -- changing periods to double underscores, and updating Last appropriately.
310 procedure Set_Unit_Number (U : Unit_Id);
311 -- Sets unit number (first unit is 1, leading zeroes output to line
312 -- up all output unit numbers nicely as required by the value, and
313 -- by the total number of units.
315 procedure Tab_To (N : Natural);
316 -- If Last is greater than or equal to N, no effect, otherwise store
317 -- blanks in Statement_Buffer bumping Last, until Last = N.
319 procedure Write_Info_Ada_C (Ada : String; C : String; Common : String);
320 -- For C code case, write C & Common, for Ada case write Ada & Common
321 -- to current binder output file using Write_Binder_Info.
323 procedure Write_Statement_Buffer;
324 -- Write out contents of statement buffer up to Last, and reset Last to 0
326 procedure Write_Statement_Buffer (S : String);
327 -- First writes its argument (using Set_String (S)), then writes out the
328 -- contents of statement buffer up to Last, and reset Last to 0
330 ----------------------
331 -- Gen_Adafinal_Ada --
332 ----------------------
334 procedure Gen_Adafinal_Ada is
337 WBI (" procedure " & Ada_Final_Name.all & " is");
340 -- If compiling for the JVM, we directly call Adafinal because
341 -- we don't import it via Do_Finalize (see Gen_Output_File_Ada).
343 if Hostparm.Java_VM then
344 WBI (" System.Standard_Library.Adafinal;");
346 -- If there is no finalization, there is nothing to do
348 elsif Cumulative_Restrictions.Set (No_Finalization) then
351 WBI (" Do_Finalize;");
354 WBI (" end " & Ada_Final_Name.all & ";");
355 end Gen_Adafinal_Ada;
361 procedure Gen_Adafinal_C is
363 WBI ("void " & Ada_Final_Name.all & " () {");
364 WBI (" system__standard_library__adafinal ();");
369 ---------------------
370 -- Gen_Adainit_Ada --
371 ---------------------
373 procedure Gen_Adainit_Ada is
374 Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority;
377 WBI (" procedure " & Ada_Init_Name.all & " is");
379 -- Generate externals for elaboration entities
381 for E in Elab_Order.First .. Elab_Order.Last loop
383 Unum : constant Unit_Id := Elab_Order.Table (E);
384 U : Unit_Record renames Units.Table (Unum);
387 -- Check for Elab_Entity to be set for this unit
391 -- Don't generate reference for stand alone library
393 and then not U.SAL_Interface
395 -- Don't generate reference for predefined file in No_Run_Time
396 -- mode, since we don't include the object files in this case
400 and then Is_Predefined_File_Name (U.Sfile))
404 Set_Unit_Number (Unum);
405 Set_String (" : Boolean; pragma Import (Ada, ");
407 Set_Unit_Number (Unum);
409 Get_Name_String (U.Uname);
411 -- In the case of JGNAT we need to emit an Import name
412 -- that includes the class name (using '$' separators
413 -- in the case of a child unit name).
415 if Hostparm.Java_VM then
416 for J in 1 .. Name_Len - 2 loop
417 if Name_Buffer (J) /= '.' then
418 Set_Char (Name_Buffer (J));
426 -- If the unit name is very long, then split the
427 -- Import link name across lines using "&" (occurs
428 -- in some C2 tests).
430 if 2 * Name_Len + 60 > Hostparm.Max_Line_Length then
432 Write_Statement_Buffer;
438 Set_String ("_E"");");
439 Write_Statement_Buffer;
444 Write_Statement_Buffer;
446 -- If the standard library is suppressed, then the only global variable
447 -- that might be needed (by the Ravenscar profile) is the priority of
448 -- the environment. Also no exception tables are needed.
450 if Suppress_Standard_Library_On_Target then
451 if Main_Priority /= No_Main_Priority then
452 WBI (" Main_Priority : Integer;");
453 WBI (" pragma Import (C, Main_Priority," &
454 " ""__gl_main_priority"");");
460 if Main_Priority /= No_Main_Priority then
461 Set_String (" Main_Priority := ");
462 Set_Int (Main_Priority);
464 Write_Statement_Buffer;
470 -- Normal case (standard library not suppressed). Global values are
471 -- assigned using the runtime routine Set_Globals (we have to use
472 -- the routine call, rather than define the globals in the binder
473 -- file to deal with cross-library calls in some systems.
476 -- Generate restrictions string
478 Set_String (" Restrictions : constant String :=");
479 Write_Statement_Buffer;
482 Gen_Restrictions_String_1;
484 Write_Statement_Buffer;
487 Gen_Restrictions_String_2;
488 Set_String (""" & ASCII.Nul;");
489 Write_Statement_Buffer;
492 -- Generate Interrupt_State pragma string
494 Set_String (" Interrupt_States : constant String :=");
495 Write_Statement_Buffer;
504 for J in 0 .. IS_Pragma_Settings.Last loop
507 Write_Statement_Buffer;
515 Set_Char (IS_Pragma_Settings.Table (J));
520 Write_Statement_Buffer;
523 -- Generate spec for Set_Globals procedure
525 WBI (" procedure Set_Globals");
526 WBI (" (Main_Priority : Integer;");
527 WBI (" Time_Slice_Value : Integer;");
528 WBI (" WC_Encoding : Character;");
529 WBI (" Locking_Policy : Character;");
530 WBI (" Queuing_Policy : Character;");
531 WBI (" Task_Dispatching_Policy : Character;");
533 WBI (" Restrictions : System.Address;");
534 WBI (" Interrupt_States : System.Address;");
535 WBI (" Num_Interrupt_States : Integer;");
536 WBI (" Unreserve_All_Interrupts : Integer;");
537 WBI (" Exception_Tracebacks : Integer;");
538 WBI (" Zero_Cost_Exceptions : Integer;");
539 WBI (" Detect_Blocking : Integer);");
540 WBI (" pragma Import (C, Set_Globals, ""__gnat_set_globals"");");
542 -- Import entry point for elaboration time signal handler
543 -- installation, and indication of if it's been called previously.
546 WBI (" procedure Install_Handler;");
547 WBI (" pragma Import (C, Install_Handler, " &
548 """__gnat_install_handler"");");
550 WBI (" Handler_Installed : Integer;");
551 WBI (" pragma Import (C, Handler_Installed, " &
552 """__gnat_handler_installed"");");
554 -- Generate exception table
556 Gen_Exception_Table_Ada;
558 -- Generate the call to Set_Globals
560 WBI (" Set_Globals");
562 Set_String (" (Main_Priority => ");
563 Set_Int (Main_Priority);
565 Write_Statement_Buffer;
567 Set_String (" Time_Slice_Value => ");
569 if Task_Dispatching_Policy_Specified = 'F'
570 and then ALIs.Table (ALIs.First).Time_Slice_Value = -1
574 Set_Int (ALIs.Table (ALIs.First).Time_Slice_Value);
578 Write_Statement_Buffer;
580 Set_String (" WC_Encoding => '");
581 Set_Char (ALIs.Table (ALIs.First).WC_Encoding);
583 Write_Statement_Buffer;
585 Set_String (" Locking_Policy => '");
586 Set_Char (Locking_Policy_Specified);
588 Write_Statement_Buffer;
590 Set_String (" Queuing_Policy => '");
591 Set_Char (Queuing_Policy_Specified);
593 Write_Statement_Buffer;
595 Set_String (" Task_Dispatching_Policy => '");
596 Set_Char (Task_Dispatching_Policy_Specified);
598 Write_Statement_Buffer;
600 WBI (" Restrictions => Restrictions'Address,");
602 WBI (" Interrupt_States => " &
603 "Interrupt_States'Address,");
605 Set_String (" Num_Interrupt_States => ");
606 Set_Int (IS_Pragma_Settings.Last + 1);
608 Write_Statement_Buffer;
610 Set_String (" Unreserve_All_Interrupts => ");
612 if Unreserve_All_Interrupts_Specified then
619 Write_Statement_Buffer;
621 Set_String (" Exception_Tracebacks => ");
623 if Exception_Tracebacks then
630 Write_Statement_Buffer;
632 Set_String (" Zero_Cost_Exceptions => ");
634 if Zero_Cost_Exceptions_Specified then
641 Write_Statement_Buffer;
643 Set_String (" Detect_Blocking => ");
645 if Detect_Blocking then
652 Write_Statement_Buffer;
654 -- Generate call to Install_Handler
657 WBI (" if Handler_Installed = 0 then");
658 WBI (" Install_Handler;");
662 -- Generate call to set Initialize_Scalar values if active
664 if Initialize_Scalars_Used then
666 Set_String (" System.Scalar_Values.Initialize ('");
667 Set_Char (Initialize_Scalars_Mode1);
669 Set_Char (Initialize_Scalars_Mode2);
671 Write_Statement_Buffer;
674 -- Generate assignment of default secondary stack size if set
676 if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then
678 Set_String (" System.Secondary_Stack.");
679 Set_String ("Default_Secondary_Stack_Size := ");
680 Set_Int (Opt.Default_Sec_Stack_Size);
682 Write_Statement_Buffer;
685 -- Generate elaboration calls
690 WBI (" end " & Ada_Init_Name.all & ";");
697 procedure Gen_Adainit_C is
698 Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority;
701 WBI ("void " & Ada_Init_Name.all & " (void)");
704 -- Generate externals for elaboration entities
706 for E in Elab_Order.First .. Elab_Order.Last loop
708 Unum : constant Unit_Id := Elab_Order.Table (E);
709 U : Unit_Record renames Units.Table (Unum);
712 -- Check for Elab entity to be set for this unit
716 -- Don't generate reference for stand alone library
718 and then not U.SAL_Interface
720 -- Don't generate reference for predefined file in No_Run_Time
721 -- mode, since we don't include the object files in this case
725 and then Is_Predefined_File_Name (U.Sfile))
727 Set_String (" extern char ");
728 Get_Name_String (U.Uname);
731 Write_Statement_Buffer;
736 Write_Statement_Buffer;
738 -- Standard library suppressed
740 if Suppress_Standard_Library_On_Target then
742 -- Case of High_Integrity_Mode mode. Set __gl_main_priority if needed
743 -- for the Ravenscar profile.
745 if Main_Priority /= No_Main_Priority then
746 Set_String (" extern int __gl_main_priority = ");
747 Set_Int (Main_Priority);
749 Write_Statement_Buffer;
752 -- Normal case (standard library not suppressed)
755 -- Generate definition for restrictions string
757 Set_String (" const char *restrictions = """);
758 Gen_Restrictions_String_1;
759 Gen_Restrictions_String_2;
761 Write_Statement_Buffer;
763 -- Generate definition for interrupt states string
765 Set_String (" const char *interrupt_states = """);
767 for J in 0 .. IS_Pragma_Settings.Last loop
768 Set_Char (IS_Pragma_Settings.Table (J));
772 Write_Statement_Buffer;
774 -- Generate declaration for secondary stack default if needed
776 if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then
777 WBI (" extern int system__secondary_stack__" &
778 "default_secondary_stack_size;");
783 -- Code for normal case (standard library not suppressed)
785 Gen_Exception_Table_C;
787 -- Generate call to set the runtime global variables defined in
788 -- a-init.c. We define the varables in a-init.c, rather than in
789 -- the binder generated file itself to avoid undefined externals
790 -- when the runtime is linked as a shareable image library.
792 -- We call the routine from inside adainit() because this works for
793 -- both programs with and without binder generated "main" functions.
795 WBI (" __gnat_set_globals (");
798 Set_Int (Main_Priority);
801 Set_String ("/* Main_Priority */");
802 Write_Statement_Buffer;
806 if Task_Dispatching_Policy = 'F'
807 and then ALIs.Table (ALIs.First).Time_Slice_Value = -1
811 Set_Int (ALIs.Table (ALIs.First).Time_Slice_Value);
816 Set_String ("/* Time_Slice_Value */");
817 Write_Statement_Buffer;
820 Set_Char (ALIs.Table (ALIs.First).WC_Encoding);
823 Set_String ("/* WC_Encoding */");
824 Write_Statement_Buffer;
827 Set_Char (Locking_Policy_Specified);
830 Set_String ("/* Locking_Policy */");
831 Write_Statement_Buffer;
834 Set_Char (Queuing_Policy_Specified);
837 Set_String ("/* Queuing_Policy */");
838 Write_Statement_Buffer;
841 Set_Char (Task_Dispatching_Policy_Specified);
844 Set_String ("/* Tasking_Dispatching_Policy */");
845 Write_Statement_Buffer;
848 Set_String ("restrictions");
851 Set_String ("/* Restrictions */");
852 Write_Statement_Buffer;
855 Set_String ("interrupt_states");
858 Set_String ("/* Interrupt_States */");
859 Write_Statement_Buffer;
862 Set_Int (IS_Pragma_Settings.Last + 1);
865 Set_String ("/* Num_Interrupt_States */");
866 Write_Statement_Buffer;
869 Set_Int (Boolean'Pos (Unreserve_All_Interrupts_Specified));
872 Set_String ("/* Unreserve_All_Interrupts */");
873 Write_Statement_Buffer;
876 Set_Int (Boolean'Pos (Exception_Tracebacks));
879 Set_String ("/* Exception_Tracebacks */");
880 Write_Statement_Buffer;
883 Set_Int (Boolean'Pos (Zero_Cost_Exceptions_Specified));
886 Set_String ("/* Zero_Cost_Exceptions */");
887 Write_Statement_Buffer;
891 if Detect_Blocking then
899 Set_String ("/* Detect_Blocking */");
900 Write_Statement_Buffer;
903 -- Install elaboration time signal handler
905 WBI (" if (__gnat_handler_installed == 0)");
907 WBI (" __gnat_install_handler ();");
911 -- Generate call to set Initialize_Scalar values if needed
913 if Initialize_Scalars_Used then
915 Set_String (" system__scalar_values__initialize('");
916 Set_Char (Initialize_Scalars_Mode1);
918 Set_Char (Initialize_Scalars_Mode2);
920 Write_Statement_Buffer;
923 -- Generate assignment of default secondary stack size if set
925 if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then
927 Set_String (" system__secondary_stack__");
928 Set_String ("default_secondary_stack_size = ");
929 Set_Int (Opt.Default_Sec_Stack_Size);
931 Write_Statement_Buffer;
934 -- Generate elaboration calls
941 ------------------------
942 -- Gen_Elab_Calls_Ada --
943 ------------------------
945 procedure Gen_Elab_Calls_Ada is
947 for E in Elab_Order.First .. Elab_Order.Last loop
949 Unum : constant Unit_Id := Elab_Order.Table (E);
950 U : Unit_Record renames Units.Table (Unum);
953 -- This is the unit number of the spec that corresponds to
954 -- this entry. It is the same as Unum except when the body
955 -- and spec are different and we are currently processing
956 -- the body, in which case it is the spec (Unum + 1).
959 if U.Utype = Is_Body then
960 Unum_Spec := Unum + 1;
965 -- Nothing to do if predefined unit in no run time mode
967 if No_Run_Time_Mode and then Is_Predefined_File_Name (U.Sfile) then
970 -- Case of no elaboration code
974 -- The only case in which we have to do something is if
975 -- this is a body, with a separate spec, where the separate
976 -- spec has an elaboration entity defined.
978 -- In that case, this is where we set the elaboration entity
979 -- to True, we do not need to test if this has already been
980 -- done, since it is quicker to set the flag than to test it.
982 if not U.SAL_Interface and then U.Utype = Is_Body
983 and then Units.Table (Unum_Spec).Set_Elab_Entity
986 Set_Unit_Number (Unum_Spec);
987 Set_String (" := True;");
988 Write_Statement_Buffer;
991 -- Here if elaboration code is present. If binding a library
992 -- or if there is a non-Ada main subprogram then we generate:
994 -- if not uname_E then
995 -- uname'elab_[spec|body];
999 -- Otherwise, elaboration routines are called unconditionally:
1001 -- uname'elab_[spec|body];
1004 -- The uname_E assignment is skipped if this is a separate spec,
1005 -- since the assignment will be done when we process the body.
1007 elsif not U.SAL_Interface then
1008 if Force_Checking_Of_Elaboration_Flags or
1009 Interface_Library_Unit or
1010 (not Bind_Main_Program)
1012 Set_String (" if not E");
1013 Set_Unit_Number (Unum_Spec);
1014 Set_String (" then");
1015 Write_Statement_Buffer;
1020 Get_Decoded_Name_String_With_Brackets (U.Uname);
1022 if Name_Buffer (Name_Len) = 's' then
1023 Name_Buffer (Name_Len - 1 .. Name_Len + 8) := "'elab_spec";
1025 Name_Buffer (Name_Len - 1 .. Name_Len + 8) := "'elab_body";
1028 Name_Len := Name_Len + 8;
1029 Set_Casing (U.Icasing);
1032 Write_Statement_Buffer;
1034 if U.Utype /= Is_Spec then
1035 if Force_Checking_Of_Elaboration_Flags or
1036 Interface_Library_Unit or
1037 (not Bind_Main_Program)
1043 Set_Unit_Number (Unum_Spec);
1044 Set_String (" := True;");
1045 Write_Statement_Buffer;
1048 if Force_Checking_Of_Elaboration_Flags or
1049 Interface_Library_Unit or
1050 (not Bind_Main_Program)
1057 end Gen_Elab_Calls_Ada;
1059 ----------------------
1060 -- Gen_Elab_Calls_C --
1061 ----------------------
1063 procedure Gen_Elab_Calls_C is
1065 for E in Elab_Order.First .. Elab_Order.Last loop
1067 Unum : constant Unit_Id := Elab_Order.Table (E);
1068 U : Unit_Record renames Units.Table (Unum);
1070 Unum_Spec : Unit_Id;
1071 -- This is the unit number of the spec that corresponds to
1072 -- this entry. It is the same as Unum except when the body
1073 -- and spec are different and we are currently processing
1074 -- the body, in which case it is the spec (Unum + 1).
1077 if U.Utype = Is_Body then
1078 Unum_Spec := Unum + 1;
1083 -- Nothing to do if predefined unit in no run time mode
1085 if No_Run_Time_Mode and then Is_Predefined_File_Name (U.Sfile) then
1088 -- Case of no elaboration code
1090 elsif U.No_Elab then
1092 -- The only case in which we have to do something is if
1093 -- this is a body, with a separate spec, where the separate
1094 -- spec has an elaboration entity defined.
1096 -- In that case, this is where we set the elaboration entity
1097 -- to True, we do not need to test if this has already been
1098 -- done, since it is quicker to set the flag than to test it.
1100 if not U.SAL_Interface and then U.Utype = Is_Body
1101 and then Units.Table (Unum_Spec).Set_Elab_Entity
1104 Get_Name_String (U.Uname);
1106 Set_String ("_E = 1;");
1107 Write_Statement_Buffer;
1110 -- Here if elaboration code is present. If binding a library
1111 -- or if there is a non-Ada main subprogram then we generate:
1113 -- if (uname_E == 0) {
1114 -- uname__elab[s|b] ();
1118 -- The uname_E assignment is skipped if this is a separate spec,
1119 -- since the assignment will be done when we process the body.
1121 elsif not U.SAL_Interface then
1122 Get_Name_String (U.Uname);
1124 if Force_Checking_Of_Elaboration_Flags or
1125 Interface_Library_Unit or
1126 (not Bind_Main_Program)
1128 Set_String (" if (");
1130 Set_String ("_E == 0) {");
1131 Write_Statement_Buffer;
1137 Set_String ("___elab");
1138 Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body
1139 Set_String (" ();");
1140 Write_Statement_Buffer;
1142 if U.Utype /= Is_Spec then
1143 if Force_Checking_Of_Elaboration_Flags or
1144 Interface_Library_Unit or
1145 (not Bind_Main_Program)
1152 Set_String ("_E++;");
1153 Write_Statement_Buffer;
1156 if Force_Checking_Of_Elaboration_Flags or
1157 Interface_Library_Unit or
1158 (not Bind_Main_Program)
1166 end Gen_Elab_Calls_C;
1168 ----------------------
1169 -- Gen_Elab_Defs_C --
1170 ----------------------
1172 procedure Gen_Elab_Defs_C is
1174 for E in Elab_Order.First .. Elab_Order.Last loop
1176 -- Generate declaration of elaboration procedure if elaboration
1177 -- needed. Note that passive units are always excluded.
1179 if not Units.Table (Elab_Order.Table (E)).No_Elab then
1180 Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
1181 Set_String ("extern void ");
1183 Set_String ("___elab");
1184 Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body
1185 Set_String (" (void);");
1186 Write_Statement_Buffer;
1192 end Gen_Elab_Defs_C;
1194 ------------------------
1195 -- Gen_Elab_Order_Ada --
1196 ------------------------
1198 procedure Gen_Elab_Order_Ada is
1201 WBI (" -- BEGIN ELABORATION ORDER");
1203 for J in Elab_Order.First .. Elab_Order.Last loop
1204 Set_String (" -- ");
1205 Get_Name_String (Units.Table (Elab_Order.Table (J)).Uname);
1207 Write_Statement_Buffer;
1210 WBI (" -- END ELABORATION ORDER");
1211 end Gen_Elab_Order_Ada;
1213 ----------------------
1214 -- Gen_Elab_Order_C --
1215 ----------------------
1217 procedure Gen_Elab_Order_C is
1220 WBI ("/* BEGIN ELABORATION ORDER");
1222 for J in Elab_Order.First .. Elab_Order.Last loop
1223 Get_Name_String (Units.Table (Elab_Order.Table (J)).Uname);
1225 Write_Statement_Buffer;
1228 WBI (" END ELABORATION ORDER */");
1229 end Gen_Elab_Order_C;
1231 -----------------------------
1232 -- Gen_Exception_Table_Ada --
1233 -----------------------------
1235 procedure Gen_Exception_Table_Ada is
1237 Last : ALI_Id := No_ALI_Id;
1240 if not Zero_Cost_Exceptions_Specified then
1245 -- The code we generate looks like
1247 -- procedure SDP_Table_Build
1248 -- (SDP_Addresses : System.Address;
1249 -- SDP_Count : Natural;
1250 -- Elab_Addresses : System.Address;
1251 -- Elab_Addr_Count : Natural);
1252 -- pragma Import (C, SDP_Table_Build, "__gnat_SDP_Table_Build");
1254 -- ST : aliased constant array (1 .. nnn) of System.Address := (
1255 -- unit_name_1'UET_Address,
1256 -- unit_name_2'UET_Address,
1258 -- unit_name_3'UET_Address,
1260 -- EA : aliased constant array (1 .. eee) of System.Address := (
1261 -- adainit'Code_Address,
1262 -- adafinal'Code_Address,
1263 -- unit_name'elab[spec|body]'Code_Address,
1264 -- unit_name'elab[spec|body]'Code_Address,
1265 -- unit_name'elab[spec|body]'Code_Address,
1266 -- unit_name'elab[spec|body]'Code_Address);
1269 -- SDP_Table_Build (ST'Address, nnn, EA'Address, eee);
1272 for A in ALIs.First .. ALIs.Last loop
1273 if not ALIs.Table (A).SAL_Interface
1274 and then ALIs.Table (A).Unit_Exception_Table
1283 -- Happens with "gnatmake -a -f -gnatL ..."
1290 WBI (" procedure SDP_Table_Build");
1291 WBI (" (SDP_Addresses : System.Address;");
1292 WBI (" SDP_Count : Natural;");
1293 WBI (" Elab_Addresses : System.Address;");
1294 WBI (" Elab_Addr_Count : Natural);");
1296 "pragma Import (C, SDP_Table_Build, ""__gnat_SDP_Table_Build"");");
1299 Set_String (" ST : aliased constant array (1 .. ");
1301 Set_String (") of System.Address := (");
1304 Set_String ("1 => ");
1307 Write_Statement_Buffer;
1310 for A in ALIs.First .. ALIs.Last loop
1311 if not ALIs.Table (A).SAL_Interface
1312 and then ALIs.Table (A).Unit_Exception_Table
1314 Get_Decoded_Name_String_With_Brackets
1315 (Units.Table (ALIs.Table (A).First_Unit).Uname);
1316 Set_Casing (Mixed_Case);
1322 Set_String (Name_Buffer (1 .. Name_Len - 2));
1323 Set_String ("'UET_Address");
1331 Write_Statement_Buffer;
1336 Set_String (" EA : aliased constant array (1 .. ");
1338 Set_String (") of System.Address := (");
1339 Write_Statement_Buffer;
1340 Set_String (" " & Ada_Init_Name.all & "'Code_Address");
1342 -- If compiling for the JVM, we directly reference Adafinal because
1343 -- we don't import it via Do_Finalize (see Gen_Output_File_Ada).
1345 if not Cumulative_Restrictions.Set (No_Finalization) then
1347 Write_Statement_Buffer;
1349 if Hostparm.Java_VM then
1351 (" System.Standard_Library.Adafinal'Code_Address");
1354 (" Do_Finalize'Code_Address");
1358 for E in Elab_Order.First .. Elab_Order.Last loop
1359 Get_Decoded_Name_String_With_Brackets
1360 (Units.Table (Elab_Order.Table (E)).Uname);
1362 if Units.Table (Elab_Order.Table (E)).No_Elab then
1367 Write_Statement_Buffer;
1370 if Name_Buffer (Name_Len) = 's' then
1371 Name_Buffer (Name_Len - 1 .. Name_Len + 21) :=
1372 "'elab_spec'code_address";
1374 Name_Buffer (Name_Len - 1 .. Name_Len + 21) :=
1375 "'elab_body'code_address";
1378 Name_Len := Name_Len + 21;
1379 Set_Casing (Units.Table (Elab_Order.Table (E)).Icasing);
1385 Write_Statement_Buffer;
1390 Set_String (" SDP_Table_Build (ST'Address, ");
1392 Set_String (", EA'Address, ");
1395 Write_Statement_Buffer;
1396 end Gen_Exception_Table_Ada;
1398 ---------------------------
1399 -- Gen_Exception_Table_C --
1400 ---------------------------
1402 procedure Gen_Exception_Table_C is
1407 if not Zero_Cost_Exceptions_Specified then
1411 -- The code we generate looks like
1413 -- extern void *__gnat_unitname1__SDP;
1414 -- extern void *__gnat_unitname2__SDP;
1417 -- void **st[nnn] = {
1418 -- &__gnat_unitname1__SDP,
1419 -- &__gnat_unitname2__SDP,
1421 -- &__gnat_unitnamen__SDP};
1423 -- extern void unitname1__elabb ();
1424 -- extern void unitname2__elabb ();
1427 -- void (*ea[eee]) () = {
1430 -- unitname1___elab[b,s],
1431 -- unitname2___elab[b,s],
1433 -- unitnamen___elab[b,s]};
1435 -- __gnat_SDP_Table_Build (&st, nnn, &ea, eee);
1438 for A in ALIs.First .. ALIs.Last loop
1439 if not ALIs.Table (A).SAL_Interface
1440 and then ALIs.Table (A).Unit_Exception_Table
1444 Set_String (" extern void *__gnat_");
1445 Get_Name_String (Units.Table (ALIs.Table (A).First_Unit).Uname);
1447 Set_String ("__SDP");
1449 Write_Statement_Buffer;
1455 -- Happens with "gnatmake -a -f -gnatL ..."
1462 Set_String (" void **st[");
1464 Set_String ("] = {");
1465 Write_Statement_Buffer;
1468 for A in ALIs.First .. ALIs.Last loop
1469 if not ALIs.Table (A).SAL_Interface
1470 and then ALIs.Table (A).Unit_Exception_Table
1474 Set_String (" &__gnat_");
1475 Get_Name_String (Units.Table (ALIs.Table (A).First_Unit).Uname);
1477 Set_String ("__SDP");
1485 Write_Statement_Buffer;
1490 for E in Elab_Order.First .. Elab_Order.Last loop
1491 Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
1493 if Units.Table (Elab_Order.Table (E)).No_Elab then
1497 Set_String (" extern void ");
1499 Set_String ("___elab");
1500 Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body
1501 Set_String (" ();");
1502 Write_Statement_Buffer;
1507 Set_String (" void (*ea[");
1509 Set_String ("]) () = {");
1510 Write_Statement_Buffer;
1512 Set_String (" " & Ada_Init_Name.all);
1514 if not Cumulative_Restrictions.Set (No_Finalization) then
1516 Write_Statement_Buffer;
1517 Set_String (" system__standard_library__adafinal");
1520 for E in Elab_Order.First .. Elab_Order.Last loop
1521 Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
1523 if Units.Table (Elab_Order.Table (E)).No_Elab then
1528 Write_Statement_Buffer;
1531 Set_String ("___elab");
1532 Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body
1537 Write_Statement_Buffer;
1541 Set_String (" __gnat_SDP_Table_Build (&st, ");
1543 Set_String (", ea, ");
1546 Write_Statement_Buffer;
1547 end Gen_Exception_Table_C;
1553 procedure Gen_Main_Ada is
1557 if Exit_Status_Supported_On_Target then
1558 Set_String (" function ");
1560 Set_String (" procedure ");
1563 Set_String (Get_Main_Name);
1565 if Command_Line_Args_On_Target then
1566 Write_Statement_Buffer;
1567 WBI (" (argc : Integer;");
1568 WBI (" argv : System.Address;");
1569 WBI (" envp : System.Address)");
1571 if Exit_Status_Supported_On_Target then
1572 WBI (" return Integer");
1578 if Exit_Status_Supported_On_Target then
1579 Set_String (" return Integer is");
1584 Write_Statement_Buffer;
1587 if Opt.Default_Exit_Status /= 0
1588 and then Bind_Main_Program
1589 and then not Configurable_Run_Time_Mode
1591 WBI (" procedure Set_Exit_Status (Status : Integer);");
1592 WBI (" pragma Import (C, Set_Exit_Status, " &
1593 """__gnat_set_exit_status"");");
1597 -- Initialize and Finalize
1599 if not Cumulative_Restrictions.Set (No_Finalization) then
1600 WBI (" procedure initialize (Addr : System.Address);");
1601 WBI (" pragma Import (C, initialize, ""__gnat_initialize"");");
1603 WBI (" procedure finalize;");
1604 WBI (" pragma Import (C, finalize, ""__gnat_finalize"");");
1607 -- Deal with declarations for main program case
1609 if not No_Main_Subprogram then
1611 -- To call the main program, we declare it using a pragma Import
1612 -- Ada with the right link name.
1614 -- It might seem more obvious to "with" the main program, and call
1615 -- it in the normal Ada manner. We do not do this for three reasons:
1617 -- 1. It is more efficient not to recompile the main program
1618 -- 2. We are not entitled to assume the source is accessible
1619 -- 3. We don't know what options to use to compile it
1621 -- It is really reason 3 that is most critical (indeed we used
1622 -- to generate the "with", but several regression tests failed).
1626 if ALIs.Table (ALIs.First).Main_Program = Func then
1627 WBI (" Result : Integer;");
1629 WBI (" function Ada_Main_Program return Integer;");
1632 WBI (" procedure Ada_Main_Program;");
1635 Set_String (" pragma Import (Ada, Ada_Main_Program, """);
1636 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
1637 Set_Main_Program_Name;
1638 Set_String (""");");
1640 Write_Statement_Buffer;
1643 if Bind_Main_Program
1644 and then not Suppress_Standard_Library_On_Target
1646 WBI (" SEH : aliased array (1 .. 2) of Integer;");
1651 -- Generate a reference to Ada_Main_Program_Name. This symbol is
1652 -- not referenced elsewhere in the generated program, but is needed
1653 -- by the debugger (that's why it is generated in the first place).
1654 -- The reference stops Ada_Main_Program_Name from being optimized
1655 -- away by smart linkers, such as the AiX linker.
1657 if Bind_Main_Program then
1659 (" Ensure_Reference : System.Address := " &
1660 "Ada_Main_Program_Name'Address;");
1666 -- Acquire command line arguments if present on target
1668 if Command_Line_Args_On_Target then
1669 WBI (" gnat_argc := argc;");
1670 WBI (" gnat_argv := argv;");
1671 WBI (" gnat_envp := envp;");
1674 -- If configurable run time and no command line args, then nothing
1675 -- needs to be done since the gnat_argc/argv/envp variables are
1676 -- suppressed in this case.
1678 elsif Configurable_Run_Time_On_Target then
1681 -- Otherwise set dummy values (to be filled in by some other unit?)
1684 WBI (" gnat_argc := 0;");
1685 WBI (" gnat_argv := System.Null_Address;");
1686 WBI (" gnat_envp := System.Null_Address;");
1689 if Opt.Default_Exit_Status /= 0
1690 and then Bind_Main_Program
1691 and then not Configurable_Run_Time_Mode
1693 Set_String (" Set_Exit_Status (");
1694 Set_Int (Opt.Default_Exit_Status);
1696 Write_Statement_Buffer;
1699 if not Cumulative_Restrictions.Set (No_Finalization) then
1701 if not No_Main_Subprogram
1702 and then Bind_Main_Program
1703 and then not Suppress_Standard_Library_On_Target
1705 WBI (" Initialize (SEH'Address);");
1707 WBI (" Initialize (System.Null_Address);");
1711 WBI (" " & Ada_Init_Name.all & ";");
1713 if not No_Main_Subprogram then
1714 WBI (" Break_Start;");
1716 if ALIs.Table (ALIs.First).Main_Program = Proc then
1717 WBI (" Ada_Main_Program;");
1719 WBI (" Result := Ada_Main_Program;");
1723 -- Adafinal call is skipped if no finalization
1725 if not Cumulative_Restrictions.Set (No_Finalization) then
1727 -- If compiling for the JVM, we directly call Adafinal because
1728 -- we don't import it via Do_Finalize (see Gen_Output_File_Ada).
1730 if Hostparm.Java_VM then
1731 WBI (" System.Standard_Library.Adafinal;");
1733 WBI (" Do_Finalize;");
1737 -- Finalize is only called if we have a run time
1739 if not Cumulative_Restrictions.Set (No_Finalization) then
1745 if Exit_Status_Supported_On_Target then
1746 if No_Main_Subprogram
1747 or else ALIs.Table (ALIs.First).Main_Program = Proc
1749 WBI (" return (gnat_exit_status);");
1751 WBI (" return (Result);");
1762 procedure Gen_Main_C is
1764 if Exit_Status_Supported_On_Target then
1765 Set_String ("int ");
1767 Set_String ("void ");
1770 Set_String (Get_Main_Name);
1772 -- Generate command line args in prototype if present on target
1774 if Command_Line_Args_On_Target then
1775 Write_Statement_Buffer (" (int argc, char **argv, char **envp)");
1777 -- Case of no command line arguments on target
1780 Write_Statement_Buffer (" ()");
1785 -- Generate a reference to __gnat_ada_main_program_name. This symbol
1786 -- is not referenced elsewhere in the generated program, but is
1787 -- needed by the debugger (that's why it is generated in the first
1788 -- place). The reference stops Ada_Main_Program_Name from being
1789 -- optimized away by smart linkers, such as the AiX linker.
1791 if Bind_Main_Program then
1792 WBI (" char *ensure_reference __attribute__ ((__unused__)) = " &
1793 "__gnat_ada_main_program_name;");
1796 if not Suppress_Standard_Library_On_Target
1797 and then not No_Main_Subprogram
1799 WBI (" int SEH [2];");
1804 -- If main program is a function, generate result variable
1806 if ALIs.Table (ALIs.First).Main_Program = Func then
1807 WBI (" int result;");
1810 -- Set command line argument values from parameters if command line
1811 -- arguments are present on target
1813 if Command_Line_Args_On_Target then
1814 WBI (" gnat_argc = argc;");
1815 WBI (" gnat_argv = argv;");
1816 WBI (" gnat_envp = envp;");
1819 -- If configurable run-time, then nothing to do, since in this case
1820 -- the gnat_argc/argv/envp variables are entirely suppressed.
1822 elsif Configurable_Run_Time_On_Target then
1825 -- if no command line arguments on target, set dummy values
1828 WBI (" int result;");
1829 WBI (" gnat_argc = 0;");
1830 WBI (" gnat_argv = 0;");
1831 WBI (" gnat_envp = 0;");
1834 if Opt.Default_Exit_Status /= 0
1835 and then Bind_Main_Program
1836 and then not Configurable_Run_Time_Mode
1838 Set_String (" __gnat_set_exit_status (");
1839 Set_Int (Opt.Default_Exit_Status);
1841 Write_Statement_Buffer;
1844 -- The __gnat_initialize routine is used only if we have a run-time
1846 if not Suppress_Standard_Library_On_Target then
1847 if not No_Main_Subprogram and then Bind_Main_Program then
1848 WBI (" __gnat_initialize ((void *)SEH);");
1850 WBI (" __gnat_initialize ((void *)0);");
1854 WBI (" " & Ada_Init_Name.all & " ();");
1856 if not No_Main_Subprogram then
1857 WBI (" __gnat_break_start ();");
1860 -- Output main program name
1862 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
1864 -- Main program is procedure case
1866 if ALIs.Table (ALIs.First).Main_Program = Proc then
1868 Set_Main_Program_Name;
1869 Set_String (" ();");
1870 Write_Statement_Buffer;
1872 -- Main program is function case
1874 else -- ALIs.Table (ALIs_First).Main_Program = Func
1875 Set_String (" result = ");
1876 Set_Main_Program_Name;
1877 Set_String (" ();");
1878 Write_Statement_Buffer;
1883 -- Call adafinal if finalization active
1885 if not Cumulative_Restrictions.Set (No_Finalization) then
1887 WBI (" system__standard_library__adafinal ();");
1890 -- The finalize routine is used only if we have a run-time
1892 if not Suppress_Standard_Library_On_Target then
1893 WBI (" __gnat_finalize ();");
1896 -- Case of main program is a function, so the value it returns
1897 -- is the exit status in this case.
1899 if ALIs.Table (ALIs.First).Main_Program = Func then
1900 if Exit_Status_Supported_On_Target then
1902 -- VMS must use Posix exit routine in order to get the effect
1903 -- of a Unix compatible setting of the program exit status.
1904 -- For all other systems, we use the standard exit routine.
1906 if OpenVMS_On_Target then
1907 WBI (" __posix_exit (result);");
1909 WBI (" exit (result);");
1913 -- Case of main program is a procedure, in which case the exit
1914 -- status is whatever was set by a Set_Exit call most recently
1917 if Exit_Status_Supported_On_Target then
1919 -- VMS must use Posix exit routine in order to get the effect
1920 -- of a Unix compatible setting of the program exit status.
1921 -- For all other systems, we use the standard exit routine.
1923 if OpenVMS_On_Target then
1924 WBI (" __posix_exit (gnat_exit_status);");
1926 WBI (" exit (gnat_exit_status);");
1934 ------------------------------
1935 -- Gen_Object_Files_Options --
1936 ------------------------------
1938 procedure Gen_Object_Files_Options is
1940 -- This keeps track of the position in the sorted set of entries
1941 -- in the Linker_Options table of where the first entry from an
1942 -- internal file appears.
1944 procedure Write_Linker_Option;
1945 -- Write binder info linker option.
1947 -------------------------
1948 -- Write_Linker_Option --
1949 -------------------------
1951 procedure Write_Linker_Option is
1956 -- Loop through string, breaking at null's
1959 while Start < Name_Len loop
1961 -- Find null ending this section
1964 while Name_Buffer (Stop) /= ASCII.NUL
1965 and then Stop <= Name_Len loop
1969 -- Process section if non-null
1971 if Stop > Start then
1972 if Output_Linker_Option_List then
1973 Write_Str (Name_Buffer (Start .. Stop - 1));
1977 (" -- ", "", Name_Buffer (Start .. Stop - 1));
1982 end Write_Linker_Option;
1984 -- Start of processing for Gen_Object_Files_Options
1988 Write_Info_Ada_C ("-- ", "/* ", " BEGIN Object file/option list");
1990 for E in Elab_Order.First .. Elab_Order.Last loop
1992 -- If not spec that has an associated body, then generate a
1993 -- comment giving the name of the corresponding object file.
1995 if (not Units.Table (Elab_Order.Table (E)).SAL_Interface)
1996 and then Units.Table (Elab_Order.Table (E)).Utype /= Is_Spec
2000 (Units.Table (Elab_Order.Table (E)).My_ALI).Ofile_Full_Name);
2002 -- If the presence of an object file is necessary or if it
2003 -- exists, then use it.
2005 if not Hostparm.Exclude_Missing_Objects
2006 or else GNAT.OS_Lib.Is_Regular_File (Name_Buffer (1 .. Name_Len))
2008 Write_Info_Ada_C (" -- ", "", Name_Buffer (1 .. Name_Len));
2010 if Output_Object_List then
2011 Write_Str (Name_Buffer (1 .. Name_Len));
2015 -- Don't link with the shared library on VMS if an internal
2016 -- filename object is seen. Multiply defined symbols will
2020 and then Is_Internal_File_Name
2022 (Units.Table (Elab_Order.Table (E)).My_ALI).Sfile)
2024 -- Special case for g-trasym.obj, which is not included
2027 Get_Name_String (ALIs.Table
2028 (Units.Table (Elab_Order.Table (E)).My_ALI).Sfile);
2030 if Name_Buffer (1 .. 8) /= "g-trasym" then
2031 Opt.Shared_Libgnat := False;
2038 -- Add a "-Ldir" for each directory in the object path
2040 for J in 1 .. Nb_Dir_In_Obj_Search_Path loop
2042 Dir : constant String_Ptr := Dir_In_Obj_Search_Path (J);
2045 Add_Str_To_Name_Buffer ("-L");
2046 Add_Str_To_Name_Buffer (Dir.all);
2047 Write_Linker_Option;
2051 -- Sort linker options
2053 -- This sort accomplishes two important purposes:
2055 -- a) All application files are sorted to the front, and all
2056 -- GNAT internal files are sorted to the end. This results
2057 -- in a well defined dividing line between the two sets of
2058 -- files, for the purpose of inserting certain standard
2059 -- library references into the linker arguments list.
2061 -- b) Given two different units, we sort the linker options so
2062 -- that those from a unit earlier in the elaboration order
2063 -- comes later in the list. This is a heuristic designed
2064 -- to create a more friendly order of linker options when
2065 -- the operations appear in separate units. The idea is that
2066 -- if unit A must be elaborated before unit B, then it is
2067 -- more likely that B references libraries included by A,
2068 -- than vice versa, so we want the libraries included by
2069 -- A to come after the libraries included by B.
2071 -- These two criteria are implemented by function Lt_Linker_Option.
2072 -- Note that a special case of b) is that specs are elaborated before
2073 -- bodies, so linker options from specs come after linker options
2074 -- for bodies, and again, the assumption is that libraries used by
2075 -- the body are more likely to reference libraries used by the spec,
2079 (Linker_Options.Last,
2080 Move_Linker_Option'Access,
2081 Lt_Linker_Option'Access);
2083 -- Write user linker options, i.e. the set of linker options that
2084 -- come from all files other than GNAT internal files, Lgnat is
2085 -- left set to point to the first entry from a GNAT internal file,
2086 -- or past the end of the entriers if there are no internal files.
2088 Lgnat := Linker_Options.Last + 1;
2090 for J in 1 .. Linker_Options.Last loop
2091 if not Linker_Options.Table (J).Internal_File then
2092 Get_Name_String (Linker_Options.Table (J).Name);
2093 Write_Linker_Option;
2100 -- Now we insert standard linker options that must appear after the
2101 -- entries from user files, and before the entries from GNAT run-time
2102 -- files. The reason for this decision is that libraries referenced
2103 -- by internal routines may reference these standard library entries.
2105 if not Opt.No_Stdlib then
2108 if Opt.Shared_Libgnat then
2109 Add_Str_To_Name_Buffer ("-shared");
2111 Add_Str_To_Name_Buffer ("-static");
2114 -- Write directly to avoid -K output (why???)
2116 Write_Info_Ada_C (" -- ", "", Name_Buffer (1 .. Name_Len));
2118 if With_DECGNAT then
2120 Add_Str_To_Name_Buffer ("-ldecgnat");
2121 Write_Linker_Option;
2127 if Opt.Shared_Libgnat then
2128 Add_Str_To_Name_Buffer (Shared_Lib ("gnarl"));
2130 Add_Str_To_Name_Buffer ("-lgnarl");
2133 Write_Linker_Option;
2138 if Opt.Shared_Libgnat then
2139 Add_Str_To_Name_Buffer (Shared_Lib ("gnat"));
2141 Add_Str_To_Name_Buffer ("-lgnat");
2144 Write_Linker_Option;
2147 -- Write linker options from all internal files
2149 for J in Lgnat .. Linker_Options.Last loop
2150 Get_Name_String (Linker_Options.Table (J).Name);
2151 Write_Linker_Option;
2154 if Ada_Bind_File then
2155 WBI ("-- END Object file/option list ");
2157 WBI (" END Object file/option list */");
2159 end Gen_Object_Files_Options;
2161 ---------------------
2162 -- Gen_Output_File --
2163 ---------------------
2165 procedure Gen_Output_File (Filename : String) is
2166 Is_Public_Version : constant Boolean := Get_Gnat_Build_Type = Public;
2167 Is_GAP_Version : constant Boolean := Get_Gnat_Build_Type = GAP;
2170 -- Acquire settings for Interrupt_State pragmas
2172 Set_IS_Pragma_Table;
2174 -- Override Ada_Bind_File and Bind_Main_Program for Java since
2175 -- JGNAT only supports Ada code, and the main program is already
2176 -- generated by the compiler.
2178 if Hostparm.Java_VM then
2179 Ada_Bind_File := True;
2180 Bind_Main_Program := False;
2183 -- Override time slice value if -T switch is set
2185 if Time_Slice_Set then
2186 ALIs.Table (ALIs.First).Time_Slice_Value := Opt.Time_Slice_Value;
2189 -- Count number of elaboration calls
2191 for E in Elab_Order.First .. Elab_Order.Last loop
2192 if Units.Table (Elab_Order.Table (E)).No_Elab then
2195 Num_Elab_Calls := Num_Elab_Calls + 1;
2199 -- Get the time stamp of the former bind for public version warning
2201 if Is_Public_Version or Is_GAP_Version then
2202 Record_Time_From_Last_Bind;
2205 -- Generate output file in appropriate language
2207 if Ada_Bind_File then
2208 Gen_Output_File_Ada (Filename);
2210 Gen_Output_File_C (Filename);
2213 -- Periodically issue a warning when the public version is used on
2216 if Is_Public_Version then
2217 Public_Version_Warning;
2219 end Gen_Output_File;
2221 -------------------------
2222 -- Gen_Output_File_Ada --
2223 -------------------------
2225 procedure Gen_Output_File_Ada (Filename : String) is
2228 -- Name of generated bind file (spec)
2231 -- Name of generated bind file (body)
2233 Ada_Main : constant String := Get_Ada_Main_Name;
2234 -- Name to be used for generated Ada main program. See the body of
2235 -- function Get_Ada_Main_Name for details on the form of the name.
2238 -- Create spec first
2240 Create_Binder_Output (Filename, 's', Bfiles);
2242 -- If we are operating in Restrictions (No_Exception_Handlers) mode,
2243 -- then we need to make sure that the binder program is compiled with
2244 -- the same restriction, so that no exception tables are generated.
2246 if Cumulative_Restrictions.Set (No_Exception_Handlers) then
2247 WBI ("pragma Restrictions (No_Exception_Handlers);");
2250 -- Generate with of System so we can reference System.Address
2252 WBI ("with System;");
2254 -- Generate with of System.Initialize_Scalars if active
2256 if Initialize_Scalars_Used then
2257 WBI ("with System.Scalar_Values;");
2260 -- Generate with of System.Secondary_Stack if active
2262 if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then
2263 WBI ("with System.Secondary_Stack;");
2266 Resolve_Binder_Options;
2268 if not Suppress_Standard_Library_On_Target then
2270 -- Usually, adafinal is called using a pragma Import C. Since
2271 -- Import C doesn't have the same semantics for JGNAT, we use
2274 if Hostparm.Java_VM then
2275 WBI ("with System.Standard_Library;");
2279 WBI ("package " & Ada_Main & " is");
2280 WBI (" pragma Warnings (Off);");
2282 -- Main program case
2284 if Bind_Main_Program then
2286 -- Generate argc/argv stuff unless suppressed
2288 if Command_Line_Args_On_Target
2289 or not Configurable_Run_Time_On_Target
2292 WBI (" gnat_argc : Integer;");
2293 WBI (" gnat_argv : System.Address;");
2294 WBI (" gnat_envp : System.Address;");
2296 -- If the standard library is not suppressed, these variables are
2297 -- in the runtime data area for easy access from the runtime
2299 if not Suppress_Standard_Library_On_Target then
2301 WBI (" pragma Import (C, gnat_argc);");
2302 WBI (" pragma Import (C, gnat_argv);");
2303 WBI (" pragma Import (C, gnat_envp);");
2307 -- Define exit status. Again in normal mode, this is in the
2308 -- run-time library, and is initialized there, but in the
2309 -- configurable runtime case, the variable is declared and
2310 -- initialized in this file.
2314 if Configurable_Run_Time_Mode then
2315 if Exit_Status_Supported_On_Target then
2316 WBI (" gnat_exit_status : Integer := 0;");
2319 WBI (" gnat_exit_status : Integer;");
2320 WBI (" pragma Import (C, gnat_exit_status);");
2324 -- Generate the GNAT_Version and Ada_Main_Program_Name info only for
2325 -- the main program. Otherwise, it can lead under some circumstances
2326 -- to a symbol duplication during the link (for instance when a
2327 -- C program uses 2 Ada libraries)
2329 if Bind_Main_Program then
2331 WBI (" GNAT_Version : constant String :=");
2332 WBI (" ""GNAT Version: " &
2333 Gnat_Version_String & """;");
2334 WBI (" pragma Export (C, GNAT_Version, ""__gnat_version"");");
2337 Set_String (" Ada_Main_Program_Name : constant String := """);
2338 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
2339 Set_Main_Program_Name;
2340 Set_String (""" & Ascii.NUL;");
2341 Write_Statement_Buffer;
2344 (" pragma Export (C, Ada_Main_Program_Name, " &
2345 """__gnat_ada_main_program_name"");");
2349 WBI (" procedure " & Ada_Final_Name.all & ";");
2350 WBI (" pragma Export (C, " & Ada_Final_Name.all & ", """ &
2351 Ada_Final_Name.all & """);");
2354 WBI (" procedure " & Ada_Init_Name.all & ";");
2355 WBI (" pragma Export (C, " & Ada_Init_Name.all & ", """ &
2356 Ada_Init_Name.all & """);");
2358 if Bind_Main_Program then
2360 -- If we have the standard library, then Break_Start is defined
2361 -- there, but when the standard library is suppressed, Break_Start
2365 WBI (" procedure Break_Start;");
2367 if Suppress_Standard_Library_On_Target then
2368 WBI (" pragma Export (C, Break_Start, ""__gnat_break_start"");");
2370 WBI (" pragma Import (C, Break_Start, ""__gnat_break_start"");");
2375 if Exit_Status_Supported_On_Target then
2376 Set_String (" function ");
2378 Set_String (" procedure ");
2381 Set_String (Get_Main_Name);
2383 -- Generate argument list if present
2385 if Command_Line_Args_On_Target then
2386 Write_Statement_Buffer;
2387 WBI (" (argc : Integer;");
2388 WBI (" argv : System.Address;");
2390 (" envp : System.Address)");
2392 if Exit_Status_Supported_On_Target then
2393 Write_Statement_Buffer;
2394 WBI (" return Integer;");
2396 Write_Statement_Buffer (";");
2400 if Exit_Status_Supported_On_Target then
2401 Write_Statement_Buffer (" return Integer;");
2403 Write_Statement_Buffer (";");
2407 WBI (" pragma Export (C, " & Get_Main_Name & ", """ &
2408 Get_Main_Name & """);");
2417 WBI ("end " & Ada_Main & ";");
2418 Close_Binder_Output;
2420 -- Prepare to write body
2422 Create_Binder_Output (Filename, 'b', Bfileb);
2424 -- Output Source_File_Name pragmas which look like
2426 -- pragma Source_File_Name (Ada_Main, Spec_File_Name => "sss");
2427 -- pragma Source_File_Name (Ada_Main, Body_File_Name => "bbb");
2429 -- where sss/bbb are the spec/body file names respectively
2431 Get_Name_String (Bfiles);
2432 Name_Buffer (Name_Len + 1 .. Name_Len + 3) := """);";
2434 WBI ("pragma Source_File_Name (" &
2436 ", Spec_File_Name => """ &
2437 Name_Buffer (1 .. Name_Len + 3));
2439 Get_Name_String (Bfileb);
2440 Name_Buffer (Name_Len + 1 .. Name_Len + 3) := """);";
2442 WBI ("pragma Source_File_Name (" &
2444 ", Body_File_Name => """ &
2445 Name_Buffer (1 .. Name_Len + 3));
2448 WBI ("package body " & Ada_Main & " is");
2449 WBI (" pragma Warnings (Off);");
2451 -- Import the finalization procedure only if finalization active
2453 if not Cumulative_Restrictions.Set (No_Finalization) then
2455 -- In the Java case, pragma Import C cannot be used, so the
2456 -- standard Ada constructs will be used instead.
2458 if not Hostparm.Java_VM then
2460 WBI (" procedure Do_Finalize;");
2462 (" pragma Import (C, Do_Finalize, " &
2463 """system__standard_library__adafinal"");");
2472 if Bind_Main_Program then
2474 -- When suppressing the standard library then generate dummy body
2477 if Suppress_Standard_Library_On_Target then
2479 WBI (" procedure Break_Start is");
2488 -- Output object file list and the Ada body is complete
2490 Gen_Object_Files_Options;
2493 WBI ("end " & Ada_Main & ";");
2495 Close_Binder_Output;
2496 end Gen_Output_File_Ada;
2498 -----------------------
2499 -- Gen_Output_File_C --
2500 -----------------------
2502 procedure Gen_Output_File_C (Filename : String) is
2505 -- Name of generated bind file
2508 Create_Binder_Output (Filename, 'c', Bfile);
2510 Resolve_Binder_Options;
2512 WBI ("extern void __gnat_set_globals");
2513 WBI (" (int, int, char, char, char, char,");
2514 WBI (" const char *, const char *,");
2515 WBI (" int, int, int, int, int);");
2516 WBI ("extern void " & Ada_Final_Name.all & " (void);");
2517 WBI ("extern void " & Ada_Init_Name.all & " (void);");
2518 WBI ("extern void system__standard_library__adafinal (void);");
2520 if not No_Main_Subprogram then
2521 Set_String ("extern ");
2523 if Exit_Status_Supported_On_Target then
2526 Set_String ("void");
2529 Set_String (" main ");
2531 if Command_Line_Args_On_Target then
2532 Write_Statement_Buffer ("(int, char **, char **);");
2534 Write_Statement_Buffer ("(void);");
2537 if OpenVMS_On_Target then
2538 WBI ("extern void __posix_exit (int);");
2540 WBI ("extern void exit (int);");
2543 WBI ("extern void __gnat_break_start (void);");
2544 Set_String ("extern ");
2546 if ALIs.Table (ALIs.First).Main_Program = Proc then
2547 Set_String ("void ");
2549 Set_String ("int ");
2552 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
2553 Set_Main_Program_Name;
2554 Set_String (" (void);");
2555 Write_Statement_Buffer;
2558 if not Suppress_Standard_Library_On_Target then
2559 WBI ("extern void __gnat_initialize (void *);");
2560 WBI ("extern void __gnat_finalize (void);");
2561 WBI ("extern void __gnat_install_handler (void);");
2568 -- Imported variable used to track elaboration/finalization phase.
2569 -- Used only when we have a runtime.
2571 if not Suppress_Standard_Library_On_Target then
2572 WBI ("extern int __gnat_handler_installed;");
2576 -- Write argv/argc exit status stuff if main program case
2578 if Bind_Main_Program then
2580 -- First deal with argc/argv/envp. In the normal case they
2581 -- are in the run-time library.
2583 if not Configurable_Run_Time_On_Target then
2584 WBI ("extern int gnat_argc;");
2585 WBI ("extern char **gnat_argv;");
2586 WBI ("extern char **gnat_envp;");
2588 -- If configurable run time and no command line args, then the
2589 -- generation of these variables is entirely suppressed.
2591 elsif not Command_Line_Args_On_Target then
2594 -- Otherwise, in the configurable run-time case they are right in
2598 WBI ("int gnat_argc;");
2599 WBI ("char **gnat_argv;");
2600 WBI ("char **gnat_envp;");
2603 -- Similarly deal with exit status
2604 -- are in the run-time library.
2606 if not Configurable_Run_Time_On_Target then
2607 WBI ("extern int gnat_exit_status;");
2609 -- If configurable run time and no exit status on target, then
2610 -- the generation of this variables is entirely suppressed.
2612 elsif not Exit_Status_Supported_On_Target then
2615 -- Otherwise, in the configurable run-time case this variable is
2616 -- right in the binder file, and initialized to zero there.
2619 WBI ("int gnat_exit_status = 0;");
2625 -- When suppressing the standard library, the __gnat_break_start
2626 -- routine (for the debugger to get initial control) is defined in
2629 if Suppress_Standard_Library_On_Target then
2631 WBI ("void __gnat_break_start () {}");
2634 -- Generate the __gnat_version and __gnat_ada_main_program_name info
2635 -- only for the main program. Otherwise, it can lead under some
2636 -- circumstances to a symbol duplication during the link (for instance
2637 -- when a C program uses 2 Ada libraries)
2639 if Bind_Main_Program then
2641 WBI ("char __gnat_version[] = ""GNAT Version: " &
2642 Gnat_Version_String & """;");
2644 Set_String ("char __gnat_ada_main_program_name[] = """);
2645 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
2646 Set_Main_Program_Name;
2648 Write_Statement_Buffer;
2651 -- Generate the adafinal routine. In no runtime mode, this is
2652 -- not needed, since there is no finalization to do.
2654 if not Cumulative_Restrictions.Set (No_Finalization) then
2660 -- Main is only present for Ada main case
2662 if Bind_Main_Program then
2666 -- Generate versions, elaboration order, list of object files
2670 Gen_Object_Files_Options;
2672 -- C binder output is complete
2674 Close_Binder_Output;
2675 end Gen_Output_File_C;
2677 -------------------------------
2678 -- Gen_Restrictions_String_1 --
2679 -------------------------------
2681 procedure Gen_Restrictions_String_1 is
2683 for R in All_Boolean_Restrictions loop
2684 if Cumulative_Restrictions.Set (R) then
2686 elsif Cumulative_Restrictions.Violated (R) then
2692 end Gen_Restrictions_String_1;
2694 -------------------------------
2695 -- Gen_Restrictions_String_2 --
2696 -------------------------------
2698 procedure Gen_Restrictions_String_2 is
2700 for RP in All_Parameter_Restrictions loop
2701 if Cumulative_Restrictions.Set (RP) then
2703 Set_Int (Int (Cumulative_Restrictions.Value (RP)));
2708 if not Cumulative_Restrictions.Violated (RP)
2709 or else RP not in Checked_Parameter_Restrictions
2714 Set_Int (Int (Cumulative_Restrictions.Count (RP)));
2716 if Cumulative_Restrictions.Unknown (RP) then
2721 end Gen_Restrictions_String_2;
2723 ----------------------
2724 -- Gen_Versions_Ada --
2725 ----------------------
2727 -- This routine generates two sets of lines. The first set has the form:
2729 -- unnnnn : constant Integer := 16#hhhhhhhh#;
2731 -- The second set has the form
2733 -- pragma Export (C, unnnnn, unam);
2735 -- for each unit, where unam is the unit name suffixed by either B or
2736 -- S for body or spec, with dots replaced by double underscores, and
2737 -- hhhhhhhh is the version number, and nnnnn is a 5-digits serial number.
2739 procedure Gen_Versions_Ada is
2740 Ubuf : String (1 .. 6) := "u00000";
2742 procedure Increment_Ubuf;
2743 -- Little procedure to increment the serial number
2745 procedure Increment_Ubuf is
2747 for J in reverse Ubuf'Range loop
2748 Ubuf (J) := Character'Succ (Ubuf (J));
2749 exit when Ubuf (J) <= '9';
2754 -- Start of processing for Gen_Versions_Ada
2757 if Bind_For_Library then
2759 -- When building libraries, the version number of each unit can
2760 -- not be computed, since the binder does not know the full list
2761 -- of units. Therefore, the 'Version and 'Body_Version
2762 -- attributes can not supported in this case.
2769 WBI (" type Version_32 is mod 2 ** 32;");
2770 for U in Units.First .. Units.Last loop
2772 WBI (" " & Ubuf & " : constant Version_32 := 16#" &
2773 Units.Table (U).Version & "#;");
2779 for U in Units.First .. Units.Last loop
2781 Set_String (" pragma Export (C, ");
2783 Set_String (", """);
2785 Get_Name_String (Units.Table (U).Uname);
2787 for K in 1 .. Name_Len loop
2788 if Name_Buffer (K) = '.' then
2792 elsif Name_Buffer (K) = '%' then
2796 Set_Char (Name_Buffer (K));
2800 if Name_Buffer (Name_Len) = 's' then
2806 Set_String (""");");
2807 Write_Statement_Buffer;
2810 end Gen_Versions_Ada;
2812 --------------------
2813 -- Gen_Versions_C --
2814 --------------------
2816 -- This routine generates a line of the form:
2818 -- unsigned unam = 0xhhhhhhhh;
2820 -- for each unit, where unam is the unit name suffixed by either B or
2821 -- S for body or spec, with dots replaced by double underscores.
2823 procedure Gen_Versions_C is
2825 if Bind_For_Library then
2827 -- When building libraries, the version number of each unit can
2828 -- not be computed, since the binder does not know the full list
2829 -- of units. Therefore, the 'Version and 'Body_Version
2830 -- attributes can not supported.
2835 for U in Units.First .. Units.Last loop
2836 Set_String ("unsigned ");
2838 Get_Name_String (Units.Table (U).Uname);
2840 for K in 1 .. Name_Len loop
2841 if Name_Buffer (K) = '.' then
2844 elsif Name_Buffer (K) = '%' then
2848 Set_Char (Name_Buffer (K));
2852 if Name_Buffer (Name_Len) = 's' then
2858 Set_String (" = 0x");
2859 Set_String (Units.Table (U).Version);
2861 Write_Statement_Buffer;
2866 -----------------------
2867 -- Get_Ada_Main_Name --
2868 -----------------------
2870 function Get_Ada_Main_Name return String is
2871 Suffix : constant String := "_00";
2872 Name : String (1 .. Opt.Ada_Main_Name.all'Length + Suffix'Length) :=
2873 Opt.Ada_Main_Name.all & Suffix;
2877 -- The main program generated by JGNAT expects a package called
2878 -- ada_<main procedure>.
2880 if Hostparm.Java_VM then
2881 -- Get main program name
2883 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
2887 return "ada_" & Name_Buffer (1 .. Name_Len - 2);
2890 -- This loop tries the following possibilities in order
2896 -- where <Ada_Main> is equal to Opt.Ada_Main_Name. By default,
2897 -- it is set to 'ada_main'.
2899 for J in 0 .. 99 loop
2901 Nlen := Name'Length - Suffix'Length;
2903 Nlen := Name'Length;
2904 Name (Name'Last) := Character'Val (J mod 10 + Character'Pos ('0'));
2905 Name (Name'Last - 1) :=
2906 Character'Val (J / 10 + Character'Pos ('0'));
2909 for K in ALIs.First .. ALIs.Last loop
2910 for L in ALIs.Table (K).First_Unit .. ALIs.Table (K).Last_Unit loop
2912 -- Get unit name, removing %b or %e at end
2914 Get_Name_String (Units.Table (L).Uname);
2915 Name_Len := Name_Len - 2;
2917 if Name_Buffer (1 .. Name_Len) = Name (1 .. Nlen) then
2923 return Name (1 .. Nlen);
2929 -- If we fall through, just use a peculiar unlikely name
2931 return ("Qwertyuiop");
2932 end Get_Ada_Main_Name;
2938 function Get_Main_Name return String is
2940 -- Explicit name given with -M switch
2942 if Bind_Alternate_Main_Name then
2943 return Alternate_Main_Name.all;
2945 -- Case of main program name to be used directly
2947 elsif Use_Ada_Main_Program_Name_On_Target then
2949 -- Get main program name
2951 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
2953 -- If this is a child name, return only the name of the child,
2954 -- since we can't have dots in a nested program name. Note that
2955 -- we do not include the %b at the end of the unit name.
2957 for J in reverse 1 .. Name_Len - 2 loop
2958 if J = 1 or else Name_Buffer (J - 1) = '.' then
2959 return Name_Buffer (J .. Name_Len - 2);
2963 raise Program_Error; -- impossible exit
2965 -- Case where "main" is to be used as default
2972 ----------------------
2973 -- Lt_Linker_Option --
2974 ----------------------
2976 function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean is
2978 -- Sort internal files last
2980 if Linker_Options.Table (Op1).Internal_File
2982 Linker_Options.Table (Op2).Internal_File
2984 -- Note: following test uses False < True
2986 return Linker_Options.Table (Op1).Internal_File
2988 Linker_Options.Table (Op2).Internal_File;
2990 -- If both internal or both non-internal, sort according to the
2991 -- elaboration position. A unit that is elaborated later should
2992 -- come earlier in the linker options list.
2995 return Units.Table (Linker_Options.Table (Op1).Unit).Elab_Position
2997 Units.Table (Linker_Options.Table (Op2).Unit).Elab_Position;
3000 end Lt_Linker_Option;
3002 ------------------------
3003 -- Move_Linker_Option --
3004 ------------------------
3006 procedure Move_Linker_Option (From : Natural; To : Natural) is
3008 Linker_Options.Table (To) := Linker_Options.Table (From);
3009 end Move_Linker_Option;
3011 ----------------------------
3012 -- Public_Version_Warning --
3013 ----------------------------
3015 procedure Public_Version_Warning is
3016 Time : constant Int := Time_From_Last_Bind;
3018 -- Constants to help defining periods
3020 Hour : constant := 60;
3021 Day : constant := 24 * Hour;
3023 Never : constant := Integer'Last;
3024 -- Special value indicating no warnings should be given
3026 -- Constants defining when the warning is issued. Programs with more
3027 -- than Large Units will issue a warning every Period_Large amount of
3028 -- time. Smaller programs will generate a warning every Period_Small
3031 Large : constant := 20;
3032 -- Threshold for considering a program small or large
3034 Period_Large : constant := Day;
3035 -- Periodic warning time for large programs
3037 Period_Small : constant := Never;
3038 -- Periodic warning time for small programs
3043 -- Compute the number of units that are not GNAT internal files
3046 for A in ALIs.First .. ALIs.Last loop
3047 if not Is_Internal_File_Name (ALIs.Table (A).Sfile) then
3048 Nb_Unit := Nb_Unit + 1;
3052 -- Do not emit the message if the last message was emitted in the
3053 -- specified period taking into account the number of units.
3055 pragma Warnings (Off);
3056 -- Turn off warning of constant condition, which may happen here
3057 -- depending on the choice of constants in the above declarations.
3059 if Nb_Unit < Large and then Time <= Period_Small then
3061 elsif Time <= Period_Large then
3065 pragma Warnings (On);
3068 Write_Str ("IMPORTANT NOTICE:");
3070 Write_Str (" This version of GNAT is unsupported"
3071 & " and comes with absolutely no warranty.");
3073 Write_Str (" If you intend to evaluate or use GNAT for building "
3074 & "commercial applications,");
3076 Write_Str (" please consult http://www.gnat.com/ for information");
3078 Write_Str (" on the GNAT Professional product line.");
3081 end Public_Version_Warning;
3083 ----------------------------
3084 -- Resolve_Binder_Options --
3085 ----------------------------
3087 procedure Resolve_Binder_Options is
3089 for E in Elab_Order.First .. Elab_Order.Last loop
3090 Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
3092 -- The procedure of looking for specific packages and setting
3093 -- flags is somewhat dubious, but there isn't a good alternative
3094 -- at the current time ???
3096 if Name_Buffer (1 .. 19) = "system.os_interface" then
3100 if Hostparm.OpenVMS and then Name_Buffer (1 .. 5) = "dec%s" then
3101 With_DECGNAT := True;
3104 end Resolve_Binder_Options;
3110 procedure Set_Char (C : Character) is
3113 Statement_Buffer (Last) := C;
3120 procedure Set_EA_Last is
3122 -- When there is no finalization, only adainit is added
3124 if Cumulative_Restrictions.Set (No_Finalization) then
3125 Set_Int (Num_Elab_Calls + 1);
3127 -- When there is finalization, both adainit and adafinal are added
3130 Set_Int (Num_Elab_Calls + 2);
3138 procedure Set_Int (N : Int) is
3150 Statement_Buffer (Last) :=
3151 Character'Val (N mod 10 + Character'Pos ('0'));
3155 -------------------------
3156 -- Set_IS_Pragma_Table --
3157 -------------------------
3159 procedure Set_IS_Pragma_Table is
3161 for F in ALIs.First .. ALIs.Last loop
3162 for K in ALIs.Table (F).First_Interrupt_State ..
3163 ALIs.Table (F).Last_Interrupt_State
3166 Inum : constant Int :=
3167 Interrupt_States.Table (K).Interrupt_Id;
3168 Stat : constant Character :=
3169 Interrupt_States.Table (K).Interrupt_State;
3172 while IS_Pragma_Settings.Last < Inum loop
3173 IS_Pragma_Settings.Append ('n');
3176 IS_Pragma_Settings.Table (Inum) := Stat;
3180 end Set_IS_Pragma_Table;
3182 ---------------------------
3183 -- Set_Main_Program_Name --
3184 ---------------------------
3186 procedure Set_Main_Program_Name is
3188 -- Note that name has %b on the end which we ignore
3190 -- First we output the initial _ada_ since we know that the main
3191 -- program is a library level subprogram.
3193 Set_String ("_ada_");
3195 -- Copy name, changing dots to double underscores
3197 for J in 1 .. Name_Len - 2 loop
3198 if Name_Buffer (J) = '.' then
3201 Set_Char (Name_Buffer (J));
3204 end Set_Main_Program_Name;
3206 ---------------------
3207 -- Set_Name_Buffer --
3208 ---------------------
3210 procedure Set_Name_Buffer is
3212 for J in 1 .. Name_Len loop
3213 Set_Char (Name_Buffer (J));
3215 end Set_Name_Buffer;
3221 procedure Set_String (S : String) is
3223 Statement_Buffer (Last + 1 .. Last + S'Length) := S;
3224 Last := Last + S'Length;
3231 procedure Set_Unit_Name is
3233 for J in 1 .. Name_Len - 2 loop
3234 if Name_Buffer (J) /= '.' then
3235 Set_Char (Name_Buffer (J));
3242 ---------------------
3243 -- Set_Unit_Number --
3244 ---------------------
3246 procedure Set_Unit_Number (U : Unit_Id) is
3247 Num_Units : constant Nat := Nat (Units.Last) - Nat (Unit_Id'First);
3248 Unum : constant Nat := Nat (U) - Nat (Unit_Id'First);
3251 if Num_Units >= 10 and then Unum < 10 then
3255 if Num_Units >= 100 and then Unum < 100 then
3260 end Set_Unit_Number;
3266 procedure Tab_To (N : Natural) is
3273 ----------------------
3274 -- Write_Info_Ada_C --
3275 ----------------------
3277 procedure Write_Info_Ada_C (Ada : String; C : String; Common : String) is
3279 if Ada_Bind_File then
3281 S : String (1 .. Ada'Length + Common'Length);
3283 S (1 .. Ada'Length) := Ada;
3284 S (Ada'Length + 1 .. S'Length) := Common;
3290 S : String (1 .. C'Length + Common'Length);
3292 S (1 .. C'Length) := C;
3293 S (C'Length + 1 .. S'Length) := Common;
3297 end Write_Info_Ada_C;
3299 ----------------------------
3300 -- Write_Statement_Buffer --
3301 ----------------------------
3303 procedure Write_Statement_Buffer is
3305 WBI (Statement_Buffer (1 .. Last));
3307 end Write_Statement_Buffer;
3309 procedure Write_Statement_Buffer (S : String) is
3312 Write_Statement_Buffer;
3313 end Write_Statement_Buffer;