1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, 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 3, 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
27 with Binde; use Binde;
28 with Casing; use Casing;
29 with Fname; use Fname;
30 with Gnatvsn; use Gnatvsn;
32 with Namet; use Namet;
34 with Osint; use Osint;
35 with Osint.B; use Osint.B;
36 with Output; use Output;
37 with Rident; use Rident;
38 with Table; use Table;
39 with Targparm; use Targparm;
40 with Types; use Types;
42 with System.OS_Lib; use System.OS_Lib;
43 with System.WCh_Con; use System.WCh_Con;
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 System_Restrictions_Used : Boolean;
67 -- Flag indicating whether the unit System.Restrictions is in the closure
68 -- of the partition. This is set by Check_System_Restrictions_Used, and
69 -- is used to determine whether or not to initialize the restrictions
70 -- information in the body of the binder generated file (we do not want
71 -- to do this unconditionally, since it drags in the System.Restrictions
72 -- unit unconditionally, which is unpleasand, especially for ZFP etc.)
74 ----------------------------------
75 -- Interface_State Pragma Table --
76 ----------------------------------
78 -- This table assembles the interface state pragma information from
79 -- all the units in the partition. Note that Bcheck has already checked
80 -- that the information is consistent across units. The entries
81 -- in this table are n/u/r/s for not set/user/runtime/system.
83 package IS_Pragma_Settings is new Table.Table (
84 Table_Component_Type => Character,
85 Table_Index_Type => Int,
88 Table_Increment => 200,
89 Table_Name => "IS_Pragma_Settings");
91 -- This table assembles the Priority_Specific_Dispatching pragma
92 -- information from all the units in the partition. Note that Bcheck has
93 -- already checked that the information is consistent across units.
94 -- The entries in this table are the upper case first character of the
95 -- policy name, e.g. 'F' for FIFO_Within_Priorities.
97 package PSD_Pragma_Settings is new Table.Table (
98 Table_Component_Type => Character,
99 Table_Index_Type => Int,
100 Table_Low_Bound => 0,
101 Table_Initial => 100,
102 Table_Increment => 200,
103 Table_Name => "PSD_Pragma_Settings");
105 ----------------------
106 -- Run-Time Globals --
107 ----------------------
109 -- This section documents the global variables that set from the
110 -- generated binder file.
112 -- Main_Priority : Integer;
113 -- Time_Slice_Value : Integer;
114 -- Heap_Size : Natural;
115 -- WC_Encoding : Character;
116 -- Locking_Policy : Character;
117 -- Queuing_Policy : Character;
118 -- Task_Dispatching_Policy : Character;
119 -- Priority_Specific_Dispatching : System.Address;
120 -- Num_Specific_Dispatching : Integer;
121 -- Restrictions : System.Address;
122 -- Interrupt_States : System.Address;
123 -- Num_Interrupt_States : Integer;
124 -- Unreserve_All_Interrupts : Integer;
125 -- Exception_Tracebacks : Integer;
126 -- Zero_Cost_Exceptions : Integer;
127 -- Detect_Blocking : Integer;
128 -- Default_Stack_Size : Integer;
129 -- Leap_Seconds_Support : Integer;
131 -- Main_Priority is the priority value set by pragma Priority in the main
132 -- program. If no such pragma is present, the value is -1.
134 -- Time_Slice_Value is the time slice value set by pragma Time_Slice in the
135 -- main program, or by the use of a -Tnnn parameter for the binder (if both
136 -- are present, the binder value overrides). The value is in milliseconds.
137 -- A value of zero indicates that time slicing should be suppressed. If no
138 -- pragma is present, and no -T switch was used, the value is -1.
140 -- Heap_Size is the heap to use for memory allocations set by use of a
141 -- -Hnn parameter for the binder or by the GNAT$NO_MALLOC_64 logical.
142 -- Valid values are 32 and 64. This switch is only available on VMS.
144 -- WC_Encoding shows the wide character encoding method used for the main
145 -- program. This is one of the encoding letters defined in
146 -- System.WCh_Con.WC_Encoding_Letters.
148 -- Locking_Policy is a space if no locking policy was specified for the
149 -- partition. If a locking policy was specified, the value is the upper
150 -- case first character of the locking policy name, for example, 'C' for
153 -- Queuing_Policy is a space if no queuing policy was specified for the
154 -- partition. If a queuing policy was specified, the value is the upper
155 -- case first character of the queuing policy name for example, 'F' for
158 -- Task_Dispatching_Policy is a space if no task dispatching policy was
159 -- specified for the partition. If a task dispatching policy was specified,
160 -- the value is the upper case first character of the policy name, e.g. 'F'
161 -- for FIFO_Within_Priorities.
163 -- Priority_Specific_Dispatching is the address of a string used to store
164 -- the task dispatching policy specified for the different priorities in
165 -- the partition. The length of this string is determined by the last
166 -- priority for which such a pragma applies (the string will be a null
167 -- string if no specific dispatching policies were used). If pragma were
168 -- present, the entries apply to the priorities in sequence from the first
169 -- priority. The value stored is the upper case first character of the
170 -- policy name, or 'F' (for FIFO_Within_Priorities) as the default value
171 -- for those priority ranges not specified.
173 -- Num_Specific_Dispatching is the length of the
174 -- Priority_Specific_Dispatching string. It will be set to zero if no
175 -- Priority_Specific_Dispatching pragmas are present.
177 -- Restrictions is the address of a null-terminated string specifying the
178 -- restrictions information for the partition. The format is identical to
179 -- that of the parameter string found on R lines in ali files (see Lib.Writ
180 -- spec in lib-writ.ads for full details). The difference is that in this
181 -- context the values are the cumulative ones for the entire partition.
183 -- Interrupt_States is the address of a string used to specify the
184 -- cumulative results of Interrupt_State pragmas used in the partition.
185 -- The length of this string is determined by the last interrupt for which
186 -- such a pragma is given (the string will be a null string if no pragmas
187 -- were used). If pragma were present the entries apply to the interrupts
188 -- in sequence from the first interrupt, and are set to one of four
189 -- possible settings: 'n' for not specified, 'u' for user, 'r' for run
190 -- time, 's' for system, see description of Interrupt_State pragma for
193 -- Num_Interrupt_States is the length of the Interrupt_States string. It
194 -- will be set to zero if no Interrupt_State pragmas are present.
196 -- Unreserve_All_Interrupts is set to one if at least one unit in the
197 -- partition had a pragma Unreserve_All_Interrupts, and zero otherwise.
199 -- Exception_Tracebacks is set to one if the -E parameter was present
200 -- in the bind and to zero otherwise. Note that on some targets exception
201 -- tracebacks are provided by default, so a value of zero for this
202 -- parameter does not necessarily mean no trace backs are available.
204 -- Zero_Cost_Exceptions is set to one if zero cost exceptions are used for
205 -- this partition, and to zero if longjmp/setjmp exceptions are used.
207 -- Detect_Blocking indicates whether pragma Detect_Blocking is active or
208 -- not. A value of zero indicates that the pragma is not present, while a
209 -- value of 1 signals its presence in the partition.
211 -- Default_Stack_Size is the default stack size used when creating an Ada
212 -- task with no explicit Storage_Size clause.
214 -- Leap_Seconds_Support denotes whether leap seconds have been enabled or
215 -- disabled. A value of zero indicates that leap seconds are turned "off",
216 -- while a value of one signifies "on" status.
218 -----------------------
219 -- Local Subprograms --
220 -----------------------
222 procedure WBI (Info : String) renames Osint.B.Write_Binder_Info;
223 -- Convenient shorthand used throughout
225 procedure Check_System_Restrictions_Used;
226 -- Sets flag System_Restrictions_Used (Set to True if and only if the unit
227 -- System.Restrictions is present in the partition, otherwise False).
229 procedure Gen_Adainit_Ada;
230 -- Generates the Adainit procedure (Ada code case)
232 procedure Gen_Adainit_C;
233 -- Generates the Adainit procedure (C code case)
235 procedure Gen_Adafinal_Ada;
236 -- Generate the Adafinal procedure (Ada code case)
238 procedure Gen_Adafinal_C;
239 -- Generate the Adafinal procedure (C code case)
241 procedure Gen_Elab_Calls_Ada;
242 -- Generate sequence of elaboration calls (Ada code case)
244 procedure Gen_Elab_Calls_C;
245 -- Generate sequence of elaboration calls (C code case)
247 procedure Gen_Elab_Order_Ada;
248 -- Generate comments showing elaboration order chosen (Ada case)
250 procedure Gen_Elab_Order_C;
251 -- Generate comments showing elaboration order chosen (C case)
253 procedure Gen_Elab_Defs_C;
254 -- Generate sequence of definitions for elaboration routines (C code case)
256 procedure Gen_Main_Ada;
257 -- Generate procedure main (Ada code case)
259 procedure Gen_Main_C;
260 -- Generate main() procedure (C code case)
262 procedure Gen_Object_Files_Options;
263 -- Output comments containing a list of the full names of the object
264 -- files to be linked and the list of linker options supplied by
265 -- Linker_Options pragmas in the source. (C and Ada code case)
267 procedure Gen_Output_File_Ada (Filename : String);
268 -- Generate output file (Ada code case)
270 procedure Gen_Output_File_C (Filename : String);
271 -- Generate output file (C code case)
273 procedure Gen_Restrictions_Ada;
274 -- Generate initialization of restrictions variable (Ada code case)
276 procedure Gen_Restrictions_C;
277 -- Generate initialization of restrictions variable (C code case)
279 procedure Gen_Versions_Ada;
280 -- Output series of definitions for unit versions (Ada code case)
282 procedure Gen_Versions_C;
283 -- Output series of definitions for unit versions (C code case)
285 function Get_Ada_Main_Name return String;
286 -- This function is used in the Ada main output case to compute a usable
287 -- name for the generated main program. The normal main program name is
288 -- Ada_Main, but this won't work if the user has a unit with this name.
289 -- This function tries Ada_Main first, and if there is such a clash, then
290 -- it tries Ada_Name_01, Ada_Name_02 ... Ada_Name_99 in sequence.
292 function Get_Main_Unit_Name (S : String) return String;
293 -- Return the main unit name corresponding to S by replacing '.' with '_'
295 function Get_Main_Name return String;
296 -- This function is used in the Ada main output case to compute the
297 -- correct external main program. It is "main" by default, unless the
298 -- flag Use_Ada_Main_Program_Name_On_Target is set, in which case it
299 -- is the name of the Ada main name without the "_ada". This default
300 -- can be overridden explicitly using the -Mname binder switch.
302 function Get_WC_Encoding return Character;
303 -- Return wide character encoding method to set as WC_Encoding in output.
304 -- If -W has been used, returns the specified encoding, otherwise returns
305 -- the encoding method used for the main program source. If there is no
306 -- main program source (-z switch used), returns brackets ('b').
308 function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean;
309 -- Compare linker options, when sorting, first according to
310 -- Is_Internal_File (internal files come later) and then by
311 -- elaboration order position (latest to earliest).
313 procedure Move_Linker_Option (From : Natural; To : Natural);
314 -- Move routine for sorting linker options
316 procedure Resolve_Binder_Options;
317 -- Set the value of With_GNARL and With_DECGNAT. The latter only on VMS
318 -- since it tests for a package named "dec" which might cause a conflict
319 -- on non-VMS systems.
321 procedure Set_Char (C : Character);
322 -- Set given character in Statement_Buffer at the Last + 1 position
323 -- and increment Last by one to reflect the stored character.
325 procedure Set_Int (N : Int);
326 -- Set given value in decimal in Statement_Buffer with no spaces
327 -- starting at the Last + 1 position, and updating Last past the value.
328 -- A minus sign is output for a negative value.
330 procedure Set_Boolean (B : Boolean);
331 -- Set given boolean value in Statement_Buffer at the Last + 1 position
332 -- and update Last past the value.
334 procedure Set_IS_Pragma_Table;
335 -- Initializes contents of IS_Pragma_Settings table from ALI table
337 procedure Set_Main_Program_Name;
338 -- Given the main program name in Name_Buffer (length in Name_Len)
339 -- generate the name of the routine to be used in the call. The name
340 -- is generated starting at Last + 1, and Last is updated past it.
342 procedure Set_Name_Buffer;
343 -- Set the value stored in positions 1 .. Name_Len of the Name_Buffer
345 procedure Set_PSD_Pragma_Table;
346 -- Initializes contents of PSD_Pragma_Settings table from ALI table
348 procedure Set_String (S : String);
349 -- Sets characters of given string in Statement_Buffer, starting at the
350 -- Last + 1 position, and updating last past the string value.
352 procedure Set_String_Replace (S : String);
353 -- Replaces the last S'Length characters in the Statement_Buffer with
354 -- the characters of S. The caller must ensure that these characters do
355 -- in fact exist in the Statement_Buffer.
357 procedure Set_Unit_Name;
358 -- Given a unit name in the Name_Buffer, copies it to Statement_Buffer,
359 -- starting at the Last + 1 position, and updating last past the value.
360 -- changing periods to double underscores, and updating Last appropriately.
362 procedure Set_Unit_Number (U : Unit_Id);
363 -- Sets unit number (first unit is 1, leading zeroes output to line
364 -- up all output unit numbers nicely as required by the value, and
365 -- by the total number of units.
367 procedure Write_Info_Ada_C (Ada : String; C : String; Common : String);
368 -- For C code case, write C & Common, for Ada case write Ada & Common
369 -- to current binder output file using Write_Binder_Info.
371 procedure Write_Statement_Buffer;
372 -- Write out contents of statement buffer up to Last, and reset Last to 0
374 procedure Write_Statement_Buffer (S : String);
375 -- First writes its argument (using Set_String (S)), then writes out the
376 -- contents of statement buffer up to Last, and reset Last to 0
378 ------------------------------------
379 -- Check_System_Restrictions_Used --
380 ------------------------------------
382 procedure Check_System_Restrictions_Used is
384 for J in Units.First .. Units.Last loop
385 if Get_Name_String (Units.Table (J).Sfile) = "s-restri.ads" then
386 System_Restrictions_Used := True;
391 System_Restrictions_Used := False;
392 end Check_System_Restrictions_Used;
394 ----------------------
395 -- Gen_Adafinal_Ada --
396 ----------------------
398 procedure Gen_Adafinal_Ada is
401 WBI (" procedure " & Ada_Final_Name.all & " is");
404 -- If compiling for the JVM, we directly call Adafinal because
405 -- we don't import it via Do_Finalize (see Gen_Output_File_Ada).
407 if VM_Target /= No_VM then
408 WBI (" System.Standard_Library.Adafinal;");
410 -- If there is no finalization, there is nothing to do
412 elsif Cumulative_Restrictions.Set (No_Finalization) then
415 WBI (" Do_Finalize;");
418 WBI (" end " & Ada_Final_Name.all & ";");
419 end Gen_Adafinal_Ada;
425 procedure Gen_Adafinal_C is
427 WBI ("void " & Ada_Final_Name.all & " (void) {");
428 WBI (" system__standard_library__adafinal ();");
433 ---------------------
434 -- Gen_Adainit_Ada --
435 ---------------------
437 procedure Gen_Adainit_Ada is
438 Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority;
441 WBI (" procedure " & Ada_Init_Name.all & " is");
443 -- Generate externals for elaboration entities
445 for E in Elab_Order.First .. Elab_Order.Last loop
447 Unum : constant Unit_Id := Elab_Order.Table (E);
448 U : Unit_Record renames Units.Table (Unum);
451 -- Check for Elab_Entity to be set for this unit
455 -- Don't generate reference for stand alone library
457 and then not U.SAL_Interface
459 -- Don't generate reference for predefined file in No_Run_Time
460 -- mode, since we don't include the object files in this case
464 and then Is_Predefined_File_Name (U.Sfile))
468 Set_Unit_Number (Unum);
471 when No_VM | JVM_Target =>
472 Set_String (" : Boolean; pragma Import (Ada, ");
474 Set_String (" : Boolean; pragma Import (CIL, ");
478 Set_Unit_Number (Unum);
480 Get_Name_String (U.Uname);
482 -- In the case of JGNAT we need to emit an Import name
483 -- that includes the class name (using '$' separators
484 -- in the case of a child unit name).
486 if VM_Target /= No_VM then
487 for J in 1 .. Name_Len - 2 loop
488 if VM_Target = CLI_Target
489 or else Name_Buffer (J) /= '.'
491 Set_Char (Name_Buffer (J));
497 if VM_Target /= CLI_Target or else U.Unit_Kind = 's' then
500 Set_String ("_pkg.");
503 -- If the unit name is very long, then split the
504 -- Import link name across lines using "&" (occurs
505 -- in some C2 tests).
507 if 2 * Name_Len + 60 > Hostparm.Max_Line_Length then
509 Write_Statement_Buffer;
515 Set_String ("_E"");");
516 Write_Statement_Buffer;
521 Write_Statement_Buffer;
523 -- If the standard library is suppressed, then the only global variable
524 -- that might be needed (by the Ravenscar profile) is the priority of
527 if Suppress_Standard_Library_On_Target then
528 if Main_Priority /= No_Main_Priority then
529 WBI (" Main_Priority : Integer;");
530 WBI (" pragma Import (C, Main_Priority," &
531 " ""__gl_main_priority"");");
537 if Main_Priority /= No_Main_Priority then
538 Set_String (" Main_Priority := ");
539 Set_Int (Main_Priority);
541 Write_Statement_Buffer;
547 -- Normal case (standard library not suppressed). Set all global values
548 -- used by the run time.
551 WBI (" Main_Priority : Integer;");
552 WBI (" pragma Import (C, Main_Priority, " &
553 """__gl_main_priority"");");
554 WBI (" Time_Slice_Value : Integer;");
555 WBI (" pragma Import (C, Time_Slice_Value, " &
556 """__gl_time_slice_val"");");
557 WBI (" WC_Encoding : Character;");
558 WBI (" pragma Import (C, WC_Encoding, ""__gl_wc_encoding"");");
559 WBI (" Locking_Policy : Character;");
560 WBI (" pragma Import (C, Locking_Policy, " &
561 """__gl_locking_policy"");");
562 WBI (" Queuing_Policy : Character;");
563 WBI (" pragma Import (C, Queuing_Policy, " &
564 """__gl_queuing_policy"");");
565 WBI (" Task_Dispatching_Policy : Character;");
566 WBI (" pragma Import (C, Task_Dispatching_Policy, " &
567 """__gl_task_dispatching_policy"");");
568 WBI (" Priority_Specific_Dispatching : System.Address;");
569 WBI (" pragma Import (C, Priority_Specific_Dispatching, " &
570 """__gl_priority_specific_dispatching"");");
571 WBI (" Num_Specific_Dispatching : Integer;");
572 WBI (" pragma Import (C, Num_Specific_Dispatching, " &
573 """__gl_num_specific_dispatching"");");
575 WBI (" Interrupt_States : System.Address;");
576 WBI (" pragma Import (C, Interrupt_States, " &
577 """__gl_interrupt_states"");");
578 WBI (" Num_Interrupt_States : Integer;");
579 WBI (" pragma Import (C, Num_Interrupt_States, " &
580 """__gl_num_interrupt_states"");");
581 WBI (" Unreserve_All_Interrupts : Integer;");
582 WBI (" pragma Import (C, Unreserve_All_Interrupts, " &
583 """__gl_unreserve_all_interrupts"");");
585 if Exception_Tracebacks then
586 WBI (" Exception_Tracebacks : Integer;");
587 WBI (" pragma Import (C, Exception_Tracebacks, " &
588 """__gl_exception_tracebacks"");");
591 WBI (" Zero_Cost_Exceptions : Integer;");
592 WBI (" pragma Import (C, Zero_Cost_Exceptions, " &
593 """__gl_zero_cost_exceptions"");");
594 WBI (" Detect_Blocking : Integer;");
595 WBI (" pragma Import (C, Detect_Blocking, " &
596 """__gl_detect_blocking"");");
597 WBI (" Default_Stack_Size : Integer;");
598 WBI (" pragma Import (C, Default_Stack_Size, " &
599 """__gl_default_stack_size"");");
600 WBI (" Leap_Seconds_Support : Integer;");
601 WBI (" pragma Import (C, Leap_Seconds_Support, " &
602 """__gl_leap_seconds_support"");");
604 -- Import entry point for elaboration time signal handler
605 -- installation, and indication of if it's been called previously.
608 WBI (" procedure Install_Handler;");
609 WBI (" pragma Import (C, Install_Handler, " &
610 """__gnat_install_handler"");");
612 WBI (" Handler_Installed : Integer;");
613 WBI (" pragma Import (C, Handler_Installed, " &
614 """__gnat_handler_installed"");");
616 -- Import entry point for environment feature enable/disable
617 -- routine, and indication that it's been called previously.
619 if OpenVMS_On_Target then
621 WBI (" procedure Set_Features;");
622 WBI (" pragma Import (C, Set_Features, " &
623 """__gnat_set_features"");");
625 WBI (" Features_Set : Integer;");
626 WBI (" pragma Import (C, Features_Set, " &
627 """__gnat_features_set"");");
629 if Opt.Heap_Size /= 0 then
631 WBI (" Heap_Size : Integer;");
632 WBI (" pragma Import (C, Heap_Size, " &
633 """__gl_heap_size"");");
635 Write_Statement_Buffer;
639 -- Initialize stack limit variable of the environment task if the
640 -- stack check method is stack limit and stack check is enabled.
642 if Stack_Check_Limits_On_Target
643 and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set)
646 WBI (" procedure Initialize_Stack_Limit;");
647 WBI (" pragma Import (C, Initialize_Stack_Limit, " &
648 """__gnat_initialize_stack_limit"");");
651 -- Special processing when main program is CIL function/procedure
653 if VM_Target = CLI_Target
654 and then Bind_Main_Program
655 and then not No_Main_Subprogram
659 -- Function case, use Set_Exit_Status to report the returned
660 -- status code, since that is the only mechanism available.
662 if ALIs.Table (ALIs.First).Main_Program = Func then
663 WBI (" Result : Integer;");
664 WBI (" procedure Set_Exit_Status (Code : Integer);");
665 WBI (" pragma Import (C, Set_Exit_Status, " &
666 """__gnat_set_exit_status"");");
668 WBI (" function Ada_Main_Program return Integer;");
673 WBI (" procedure Ada_Main_Program;");
676 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
677 Name_Len := Name_Len - 2;
678 WBI (" pragma Import (CIL, Ada_Main_Program, """
679 & Name_Buffer (1 .. Name_Len) & "."
680 & Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len)) & """);");
685 Set_String (" Main_Priority := ");
686 Set_Int (Main_Priority);
688 Write_Statement_Buffer;
690 Set_String (" Time_Slice_Value := ");
692 if Task_Dispatching_Policy_Specified = 'F'
693 and then ALIs.Table (ALIs.First).Time_Slice_Value = -1
697 Set_Int (ALIs.Table (ALIs.First).Time_Slice_Value);
701 Write_Statement_Buffer;
703 Set_String (" WC_Encoding := '");
704 Set_Char (Get_WC_Encoding);
707 Write_Statement_Buffer;
709 Set_String (" Locking_Policy := '");
710 Set_Char (Locking_Policy_Specified);
712 Write_Statement_Buffer;
714 Set_String (" Queuing_Policy := '");
715 Set_Char (Queuing_Policy_Specified);
717 Write_Statement_Buffer;
719 Set_String (" Task_Dispatching_Policy := '");
720 Set_Char (Task_Dispatching_Policy_Specified);
722 Write_Statement_Buffer;
724 Gen_Restrictions_Ada;
726 WBI (" Priority_Specific_Dispatching :=");
727 WBI (" Local_Priority_Specific_Dispatching'Address;");
729 Set_String (" Num_Specific_Dispatching := ");
730 Set_Int (PSD_Pragma_Settings.Last + 1);
732 Write_Statement_Buffer;
734 WBI (" Interrupt_States := Local_Interrupt_States'Address;");
736 Set_String (" Num_Interrupt_States := ");
737 Set_Int (IS_Pragma_Settings.Last + 1);
739 Write_Statement_Buffer;
741 Set_String (" Unreserve_All_Interrupts := ");
743 if Unreserve_All_Interrupts_Specified then
750 Write_Statement_Buffer;
752 if Exception_Tracebacks then
753 WBI (" Exception_Tracebacks := 1;");
756 Set_String (" Zero_Cost_Exceptions := ");
758 if Zero_Cost_Exceptions_Specified then
765 Write_Statement_Buffer;
767 Set_String (" Detect_Blocking := ");
769 if Detect_Blocking then
776 Write_Statement_Buffer;
778 Set_String (" Default_Stack_Size := ");
779 Set_Int (Default_Stack_Size);
781 Write_Statement_Buffer;
783 Set_String (" Leap_Seconds_Support := ");
785 if Leap_Seconds_Support then
792 Write_Statement_Buffer;
794 -- Generate call to Install_Handler
795 -- In .NET, when binding with -z, we don't install the signal
796 -- handler to let the caller handle the last exception handler.
798 if VM_Target /= CLI_Target
799 or else Bind_Main_Program
802 WBI (" if Handler_Installed = 0 then");
803 WBI (" Install_Handler;");
807 -- Generate call to Set_Features
809 if OpenVMS_On_Target then
811 WBI (" if Features_Set = 0 then");
812 WBI (" Set_Features;");
815 -- Features_Set may twiddle the heap size according to a logical
816 -- name, but the binder switch must override.
818 if Opt.Heap_Size /= 0 then
819 Set_String (" Heap_Size := ");
820 Set_Int (Opt.Heap_Size);
822 Write_Statement_Buffer;
827 -- Generate call to set Initialize_Scalar values if active
829 if Initialize_Scalars_Used then
831 Set_String (" System.Scalar_Values.Initialize ('");
832 Set_Char (Initialize_Scalars_Mode1);
834 Set_Char (Initialize_Scalars_Mode2);
836 Write_Statement_Buffer;
839 -- Generate assignment of default secondary stack size if set
841 if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then
843 Set_String (" System.Secondary_Stack.");
844 Set_String ("Default_Secondary_Stack_Size := ");
845 Set_Int (Opt.Default_Sec_Stack_Size);
847 Write_Statement_Buffer;
850 -- Initialize stack limit variable of the environment task if the
851 -- stack check method is stack limit and stack check is enabled.
853 if Stack_Check_Limits_On_Target
854 and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set)
857 WBI (" Initialize_Stack_Limit;");
860 -- Generate elaboration calls
865 -- Case of main program is CIL function or procedure
867 if VM_Target = CLI_Target
868 and then Bind_Main_Program
869 and then not No_Main_Subprogram
871 -- For function case, use Set_Exit_Status to set result
873 if ALIs.Table (ALIs.First).Main_Program = Func then
874 WBI (" Result := Ada_Main_Program;");
875 WBI (" Set_Exit_Status (Result);");
880 WBI (" Ada_Main_Program;");
884 WBI (" end " & Ada_Init_Name.all & ";");
891 procedure Gen_Adainit_C is
892 Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority;
895 WBI ("void " & Ada_Init_Name.all & " (void)");
898 -- Generate externals for elaboration entities
900 for E in Elab_Order.First .. Elab_Order.Last loop
902 Unum : constant Unit_Id := Elab_Order.Table (E);
903 U : Unit_Record renames Units.Table (Unum);
906 -- Check for Elab entity to be set for this unit
910 -- Don't generate reference for stand alone library
912 and then not U.SAL_Interface
914 -- Don't generate reference for predefined file in No_Run_Time
915 -- mode, since we don't include the object files in this case
919 and then Is_Predefined_File_Name (U.Sfile))
921 Set_String (" extern char ");
922 Get_Name_String (U.Uname);
925 Write_Statement_Buffer;
930 Write_Statement_Buffer;
932 -- Standard library suppressed
934 if Suppress_Standard_Library_On_Target then
936 -- Case of High_Integrity_Mode mode. Set __gl_main_priority if needed
937 -- for the Ravenscar profile.
939 if Main_Priority /= No_Main_Priority then
940 WBI (" extern int __gl_main_priority;");
941 Set_String (" __gl_main_priority = ");
942 Set_Int (Main_Priority);
944 Write_Statement_Buffer;
947 -- Normal case (standard library not suppressed)
950 -- Generate definition for interrupt states string
952 Set_String (" static const char *local_interrupt_states = """);
954 for J in 0 .. IS_Pragma_Settings.Last loop
955 Set_Char (IS_Pragma_Settings.Table (J));
959 Write_Statement_Buffer;
961 -- Generate definition for priority specific dispatching string
964 (" static const char *local_priority_specific_dispatching = """);
966 for J in 0 .. PSD_Pragma_Settings.Last loop
967 Set_Char (PSD_Pragma_Settings.Table (J));
971 Write_Statement_Buffer;
973 -- Generate declaration for secondary stack default if needed
975 if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then
976 WBI (" extern int system__secondary_stack__" &
977 "default_secondary_stack_size;");
982 -- Code for normal case (standard library not suppressed)
984 -- We call the routine from inside adainit() because this works for
985 -- both programs with and without binder generated "main" functions.
987 WBI (" extern int __gl_main_priority;");
988 Set_String (" __gl_main_priority = ");
989 Set_Int (Main_Priority);
991 Write_Statement_Buffer;
993 WBI (" extern int __gl_time_slice_val;");
994 Set_String (" __gl_time_slice_val = ");
996 if Task_Dispatching_Policy = 'F'
997 and then ALIs.Table (ALIs.First).Time_Slice_Value = -1
1001 Set_Int (ALIs.Table (ALIs.First).Time_Slice_Value);
1005 Write_Statement_Buffer;
1007 WBI (" extern char __gl_wc_encoding;");
1008 Set_String (" __gl_wc_encoding = '");
1009 Set_Char (Get_WC_Encoding);
1012 Write_Statement_Buffer;
1014 WBI (" extern char __gl_locking_policy;");
1015 Set_String (" __gl_locking_policy = '");
1016 Set_Char (Locking_Policy_Specified);
1018 Write_Statement_Buffer;
1020 WBI (" extern char __gl_queuing_policy;");
1021 Set_String (" __gl_queuing_policy = '");
1022 Set_Char (Queuing_Policy_Specified);
1024 Write_Statement_Buffer;
1026 WBI (" extern char __gl_task_dispatching_policy;");
1027 Set_String (" __gl_task_dispatching_policy = '");
1028 Set_Char (Task_Dispatching_Policy_Specified);
1030 Write_Statement_Buffer;
1034 WBI (" extern const void *__gl_interrupt_states;");
1035 WBI (" __gl_interrupt_states = local_interrupt_states;");
1037 WBI (" extern int __gl_num_interrupt_states;");
1038 Set_String (" __gl_num_interrupt_states = ");
1039 Set_Int (IS_Pragma_Settings.Last + 1);
1041 Write_Statement_Buffer;
1043 WBI (" extern const void *__gl_priority_specific_dispatching;");
1044 WBI (" __gl_priority_specific_dispatching =" &
1045 " local_priority_specific_dispatching;");
1047 WBI (" extern int __gl_num_specific_dispatching;");
1048 Set_String (" __gl_num_specific_dispatching = ");
1049 Set_Int (PSD_Pragma_Settings.Last + 1);
1051 Write_Statement_Buffer;
1053 WBI (" extern int __gl_unreserve_all_interrupts;");
1054 Set_String (" __gl_unreserve_all_interrupts = ");
1055 Set_Int (Boolean'Pos (Unreserve_All_Interrupts_Specified));
1057 Write_Statement_Buffer;
1059 if Exception_Tracebacks then
1060 WBI (" extern int __gl_exception_tracebacks;");
1061 WBI (" __gl_exception_tracebacks = 1;");
1064 WBI (" extern int __gl_zero_cost_exceptions;");
1065 Set_String (" __gl_zero_cost_exceptions = ");
1066 Set_Int (Boolean'Pos (Zero_Cost_Exceptions_Specified));
1068 Write_Statement_Buffer;
1070 WBI (" extern int __gl_detect_blocking;");
1071 Set_String (" __gl_detect_blocking = ");
1073 if Detect_Blocking then
1080 Write_Statement_Buffer;
1082 WBI (" extern int __gl_default_stack_size;");
1083 Set_String (" __gl_default_stack_size = ");
1084 Set_Int (Default_Stack_Size);
1086 Write_Statement_Buffer;
1088 WBI (" extern int __gl_leap_seconds_support;");
1089 Set_String (" __gl_leap_seconds_support = ");
1091 if Leap_Seconds_Support then
1098 Write_Statement_Buffer;
1102 -- Install elaboration time signal handler
1104 WBI (" if (__gnat_handler_installed == 0)");
1106 WBI (" __gnat_install_handler ();");
1109 -- Call feature enable/disable routine
1111 if OpenVMS_On_Target then
1112 WBI (" if (__gnat_features_set == 0)");
1114 WBI (" __gnat_set_features ();");
1119 -- Initialize stack limit for the environment task if the stack
1120 -- check method is stack limit and stack check is enabled.
1122 if Stack_Check_Limits_On_Target
1123 and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set)
1126 WBI (" __gnat_initialize_stack_limit ();");
1129 -- Generate call to set Initialize_Scalar values if needed
1131 if Initialize_Scalars_Used then
1133 Set_String (" system__scalar_values__initialize('");
1134 Set_Char (Initialize_Scalars_Mode1);
1135 Set_String ("', '");
1136 Set_Char (Initialize_Scalars_Mode2);
1138 Write_Statement_Buffer;
1141 -- Generate assignment of default secondary stack size if set
1143 if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then
1145 Set_String (" system__secondary_stack__");
1146 Set_String ("default_secondary_stack_size = ");
1147 Set_Int (Opt.Default_Sec_Stack_Size);
1149 Write_Statement_Buffer;
1152 -- Generate elaboration calls
1159 ------------------------
1160 -- Gen_Elab_Calls_Ada --
1161 ------------------------
1163 procedure Gen_Elab_Calls_Ada is
1165 for E in Elab_Order.First .. Elab_Order.Last loop
1167 Unum : constant Unit_Id := Elab_Order.Table (E);
1168 U : Unit_Record renames Units.Table (Unum);
1170 Unum_Spec : Unit_Id;
1171 -- This is the unit number of the spec that corresponds to
1172 -- this entry. It is the same as Unum except when the body
1173 -- and spec are different and we are currently processing
1174 -- the body, in which case it is the spec (Unum + 1).
1177 if U.Utype = Is_Body then
1178 Unum_Spec := Unum + 1;
1183 -- Nothing to do if predefined unit in no run time mode
1185 if No_Run_Time_Mode and then Is_Predefined_File_Name (U.Sfile) then
1188 -- Case of no elaboration code
1190 elsif U.No_Elab then
1192 -- The only case in which we have to do something is if
1193 -- this is a body, with a separate spec, where the separate
1194 -- spec has an elaboration entity defined.
1196 -- In that case, this is where we set the elaboration entity
1197 -- to True, we do not need to test if this has already been
1198 -- done, since it is quicker to set the flag than to test it.
1200 if not U.SAL_Interface and then U.Utype = Is_Body
1201 and then Units.Table (Unum_Spec).Set_Elab_Entity
1204 Set_Unit_Number (Unum_Spec);
1205 Set_String (" := True;");
1206 Write_Statement_Buffer;
1209 -- Here if elaboration code is present. If binding a library
1210 -- or if there is a non-Ada main subprogram then we generate:
1212 -- if not uname_E then
1213 -- uname'elab_[spec|body];
1217 -- Otherwise, elaboration routines are called unconditionally:
1219 -- uname'elab_[spec|body];
1222 -- The uname_E assignment is skipped if this is a separate spec,
1223 -- since the assignment will be done when we process the body.
1225 elsif not U.SAL_Interface then
1226 if Force_Checking_Of_Elaboration_Flags or
1227 Interface_Library_Unit or
1228 (not Bind_Main_Program)
1230 Set_String (" if not E");
1231 Set_Unit_Number (Unum_Spec);
1232 Set_String (" then");
1233 Write_Statement_Buffer;
1238 Get_Decoded_Name_String_With_Brackets (U.Uname);
1240 if VM_Target = CLI_Target and then U.Unit_Kind /= 's' then
1241 if Name_Buffer (Name_Len) = 's' then
1242 Name_Buffer (Name_Len - 1 .. Name_Len + 12) :=
1245 Name_Buffer (Name_Len - 1 .. Name_Len + 12) :=
1249 Name_Len := Name_Len + 12;
1252 if Name_Buffer (Name_Len) = 's' then
1253 Name_Buffer (Name_Len - 1 .. Name_Len + 8) :=
1256 Name_Buffer (Name_Len - 1 .. Name_Len + 8) :=
1260 Name_Len := Name_Len + 8;
1263 Set_Casing (U.Icasing);
1266 Write_Statement_Buffer;
1268 if U.Utype /= Is_Spec then
1269 if Force_Checking_Of_Elaboration_Flags or
1270 Interface_Library_Unit or
1271 (not Bind_Main_Program)
1277 Set_Unit_Number (Unum_Spec);
1278 Set_String (" := True;");
1279 Write_Statement_Buffer;
1282 if Force_Checking_Of_Elaboration_Flags or
1283 Interface_Library_Unit or
1284 (not Bind_Main_Program)
1291 end Gen_Elab_Calls_Ada;
1293 ----------------------
1294 -- Gen_Elab_Calls_C --
1295 ----------------------
1297 procedure Gen_Elab_Calls_C is
1299 for E in Elab_Order.First .. Elab_Order.Last loop
1301 Unum : constant Unit_Id := Elab_Order.Table (E);
1302 U : Unit_Record renames Units.Table (Unum);
1304 Unum_Spec : Unit_Id;
1305 -- This is the unit number of the spec that corresponds to
1306 -- this entry. It is the same as Unum except when the body
1307 -- and spec are different and we are currently processing
1308 -- the body, in which case it is the spec (Unum + 1).
1311 if U.Utype = Is_Body then
1312 Unum_Spec := Unum + 1;
1317 -- Nothing to do if predefined unit in no run time mode
1319 if No_Run_Time_Mode and then Is_Predefined_File_Name (U.Sfile) then
1322 -- Case of no elaboration code
1324 elsif U.No_Elab then
1326 -- The only case in which we have to do something is if
1327 -- this is a body, with a separate spec, where the separate
1328 -- spec has an elaboration entity defined.
1330 -- In that case, this is where we set the elaboration entity
1331 -- to True, we do not need to test if this has already been
1332 -- done, since it is quicker to set the flag than to test it.
1334 if not U.SAL_Interface and then U.Utype = Is_Body
1335 and then Units.Table (Unum_Spec).Set_Elab_Entity
1338 Get_Name_String (U.Uname);
1340 Set_String ("_E = 1;");
1341 Write_Statement_Buffer;
1344 -- Here if elaboration code is present. If binding a library
1345 -- or if there is a non-Ada main subprogram then we generate:
1347 -- if (uname_E == 0) {
1348 -- uname__elab[s|b] ();
1352 -- The uname_E assignment is skipped if this is a separate spec,
1353 -- since the assignment will be done when we process the body.
1355 elsif not U.SAL_Interface then
1356 Get_Name_String (U.Uname);
1358 if Force_Checking_Of_Elaboration_Flags or
1359 Interface_Library_Unit or
1360 (not Bind_Main_Program)
1362 Set_String (" if (");
1364 Set_String ("_E == 0) {");
1365 Write_Statement_Buffer;
1371 Set_String ("___elab");
1372 Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body
1373 Set_String (" ();");
1374 Write_Statement_Buffer;
1376 if U.Utype /= Is_Spec then
1377 if Force_Checking_Of_Elaboration_Flags or
1378 Interface_Library_Unit or
1379 (not Bind_Main_Program)
1386 Set_String ("_E++;");
1387 Write_Statement_Buffer;
1390 if Force_Checking_Of_Elaboration_Flags or
1391 Interface_Library_Unit or
1392 (not Bind_Main_Program)
1400 end Gen_Elab_Calls_C;
1402 ----------------------
1403 -- Gen_Elab_Defs_C --
1404 ----------------------
1406 procedure Gen_Elab_Defs_C is
1408 for E in Elab_Order.First .. Elab_Order.Last loop
1410 -- Generate declaration of elaboration procedure if elaboration
1411 -- needed. Note that passive units are always excluded.
1413 if not Units.Table (Elab_Order.Table (E)).No_Elab then
1414 Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
1415 Set_String ("extern void ");
1417 Set_String ("___elab");
1418 Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body
1419 Set_String (" (void);");
1420 Write_Statement_Buffer;
1426 end Gen_Elab_Defs_C;
1428 ------------------------
1429 -- Gen_Elab_Order_Ada --
1430 ------------------------
1432 procedure Gen_Elab_Order_Ada is
1435 WBI (" -- BEGIN ELABORATION ORDER");
1437 for J in Elab_Order.First .. Elab_Order.Last loop
1438 Set_String (" -- ");
1439 Get_Name_String (Units.Table (Elab_Order.Table (J)).Uname);
1441 Write_Statement_Buffer;
1444 WBI (" -- END ELABORATION ORDER");
1445 end Gen_Elab_Order_Ada;
1447 ----------------------
1448 -- Gen_Elab_Order_C --
1449 ----------------------
1451 procedure Gen_Elab_Order_C is
1454 WBI ("/* BEGIN ELABORATION ORDER");
1456 for J in Elab_Order.First .. Elab_Order.Last loop
1457 Get_Name_String (Units.Table (Elab_Order.Table (J)).Uname);
1459 Write_Statement_Buffer;
1462 WBI (" END ELABORATION ORDER */");
1463 end Gen_Elab_Order_C;
1469 procedure Gen_Main_Ada is
1473 if Exit_Status_Supported_On_Target then
1474 Set_String (" function ");
1476 Set_String (" procedure ");
1479 Set_String (Get_Main_Name);
1481 if Command_Line_Args_On_Target then
1482 Write_Statement_Buffer;
1483 WBI (" (argc : Integer;");
1484 WBI (" argv : System.Address;");
1485 WBI (" envp : System.Address)");
1487 if Exit_Status_Supported_On_Target then
1488 WBI (" return Integer");
1494 if Exit_Status_Supported_On_Target then
1495 Set_String (" return Integer is");
1500 Write_Statement_Buffer;
1503 if Opt.Default_Exit_Status /= 0
1504 and then Bind_Main_Program
1505 and then not Configurable_Run_Time_Mode
1507 WBI (" procedure Set_Exit_Status (Status : Integer);");
1508 WBI (" pragma Import (C, Set_Exit_Status, " &
1509 """__gnat_set_exit_status"");");
1513 -- Initialize and Finalize
1515 if not Cumulative_Restrictions.Set (No_Finalization) then
1516 WBI (" procedure initialize (Addr : System.Address);");
1517 WBI (" pragma Import (C, initialize, ""__gnat_initialize"");");
1519 WBI (" procedure finalize;");
1520 WBI (" pragma Import (C, finalize, ""__gnat_finalize"");");
1523 -- If we want to analyze the stack, we have to import corresponding
1526 if Dynamic_Stack_Measurement then
1528 WBI (" procedure Output_Results;");
1529 WBI (" pragma Import (C, Output_Results, " &
1530 """__gnat_stack_usage_output_results"");");
1534 "procedure Initialize_Stack_Analysis (Buffer_Size : Natural);");
1535 WBI (" pragma Import (C, Initialize_Stack_Analysis, " &
1536 """__gnat_stack_usage_initialize"");");
1539 -- Deal with declarations for main program case
1541 if not No_Main_Subprogram then
1543 -- To call the main program, we declare it using a pragma Import
1544 -- Ada with the right link name.
1546 -- It might seem more obvious to "with" the main program, and call
1547 -- it in the normal Ada manner. We do not do this for three reasons:
1549 -- 1. It is more efficient not to recompile the main program
1550 -- 2. We are not entitled to assume the source is accessible
1551 -- 3. We don't know what options to use to compile it
1553 -- It is really reason 3 that is most critical (indeed we used
1554 -- to generate the "with", but several regression tests failed).
1558 if ALIs.Table (ALIs.First).Main_Program = Func then
1559 WBI (" Result : Integer;");
1561 WBI (" function Ada_Main_Program return Integer;");
1564 WBI (" procedure Ada_Main_Program;");
1567 Set_String (" pragma Import (Ada, Ada_Main_Program, """);
1568 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
1569 Set_Main_Program_Name;
1570 Set_String (""");");
1572 Write_Statement_Buffer;
1575 if Bind_Main_Program
1576 and then not Suppress_Standard_Library_On_Target
1578 WBI (" SEH : aliased array (1 .. 2) of Integer;");
1583 -- Generate a reference to Ada_Main_Program_Name. This symbol is
1584 -- not referenced elsewhere in the generated program, but is needed
1585 -- by the debugger (that's why it is generated in the first place).
1586 -- The reference stops Ada_Main_Program_Name from being optimized
1587 -- away by smart linkers, such as the AiX linker.
1589 -- Because this variable is unused, we make this variable "aliased"
1590 -- with a pragma Volatile in order to tell the compiler to preserve
1591 -- this variable at any level of optimization.
1593 if Bind_Main_Program then
1595 (" Ensure_Reference : aliased System.Address := " &
1596 "Ada_Main_Program_Name'Address;");
1597 WBI (" pragma Volatile (Ensure_Reference);");
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 Opt.Default_Exit_Status /= 0
1627 and then Bind_Main_Program
1628 and then not Configurable_Run_Time_Mode
1630 Set_String (" Set_Exit_Status (");
1631 Set_Int (Opt.Default_Exit_Status);
1633 Write_Statement_Buffer;
1636 if Dynamic_Stack_Measurement then
1637 Set_String (" Initialize_Stack_Analysis (");
1638 Set_Int (Dynamic_Stack_Measurement_Array_Size);
1640 Write_Statement_Buffer;
1643 if not Cumulative_Restrictions.Set (No_Finalization) then
1644 if not No_Main_Subprogram
1645 and then Bind_Main_Program
1646 and then not Suppress_Standard_Library_On_Target
1648 WBI (" Initialize (SEH'Address);");
1650 WBI (" Initialize (System.Null_Address);");
1654 WBI (" " & Ada_Init_Name.all & ";");
1656 if not No_Main_Subprogram then
1657 WBI (" Break_Start;");
1659 if ALIs.Table (ALIs.First).Main_Program = Proc then
1660 WBI (" Ada_Main_Program;");
1662 WBI (" Result := Ada_Main_Program;");
1666 -- Adafinal call is skipped if no finalization
1668 if not Cumulative_Restrictions.Set (No_Finalization) then
1670 -- If compiling for the JVM, we directly call Adafinal because
1671 -- we don't import it via Do_Finalize (see Gen_Output_File_Ada).
1673 if VM_Target = No_VM then
1674 WBI (" Do_Finalize;");
1676 WBI (" System.Standard_Library.Adafinal;");
1680 -- Prints the result of static stack analysis
1682 if Dynamic_Stack_Measurement then
1683 WBI (" Output_Results;");
1686 -- Finalize is only called if we have a run time
1688 if not Cumulative_Restrictions.Set (No_Finalization) then
1694 if Exit_Status_Supported_On_Target then
1695 if No_Main_Subprogram
1696 or else ALIs.Table (ALIs.First).Main_Program = Proc
1698 WBI (" return (gnat_exit_status);");
1700 WBI (" return (Result);");
1711 procedure Gen_Main_C is
1713 if Exit_Status_Supported_On_Target then
1714 WBI ("#include <stdlib.h>");
1715 Set_String ("int ");
1717 Set_String ("void ");
1720 Set_String (Get_Main_Name);
1722 -- Generate command line args in prototype if present on target
1724 if Command_Line_Args_On_Target then
1725 Write_Statement_Buffer (" (int argc, char **argv, char **envp)");
1727 -- Case of no command line arguments on target
1730 Write_Statement_Buffer (" (void)");
1735 -- Generate a reference to __gnat_ada_main_program_name. This symbol
1736 -- is not referenced elsewhere in the generated program, but is
1737 -- needed by the debugger (that's why it is generated in the first
1738 -- place). The reference stops Ada_Main_Program_Name from being
1739 -- optimized away by smart linkers, such as the AiX linker.
1741 -- Because this variable is unused, we declare this variable as
1742 -- volatile in order to tell the compiler to preserve it at any
1743 -- level of optimization.
1745 if Bind_Main_Program then
1746 WBI (" char * volatile ensure_reference " &
1747 "__attribute__ ((__unused__)) = " &
1748 "__gnat_ada_main_program_name;");
1751 if not Suppress_Standard_Library_On_Target
1752 and then not No_Main_Subprogram
1754 WBI (" int SEH [2];");
1759 -- If main program is a function, generate result variable
1761 if ALIs.Table (ALIs.First).Main_Program = Func then
1762 WBI (" int result;");
1765 -- Set command line argument values from parameters if command line
1766 -- arguments are present on target
1768 if Command_Line_Args_On_Target then
1769 WBI (" gnat_argc = argc;");
1770 WBI (" gnat_argv = argv;");
1771 WBI (" gnat_envp = envp;");
1774 -- If configurable run-time, then nothing to do, since in this case
1775 -- the gnat_argc/argv/envp variables are entirely suppressed.
1777 elsif Configurable_Run_Time_On_Target then
1780 -- if no command line arguments on target, set dummy values
1783 WBI (" gnat_argc = 0;");
1784 WBI (" gnat_argv = 0;");
1785 WBI (" gnat_envp = 0;");
1788 if Opt.Default_Exit_Status /= 0
1789 and then Bind_Main_Program
1790 and then not Configurable_Run_Time_Mode
1792 Set_String (" __gnat_set_exit_status (");
1793 Set_Int (Opt.Default_Exit_Status);
1795 Write_Statement_Buffer;
1798 -- Initializes dynamic stack measurement if needed
1800 if Dynamic_Stack_Measurement then
1801 Set_String (" __gnat_stack_usage_initialize (");
1802 Set_Int (Dynamic_Stack_Measurement_Array_Size);
1804 Write_Statement_Buffer;
1807 -- The __gnat_initialize routine is used only if we have a run-time
1809 if not Suppress_Standard_Library_On_Target then
1810 if not No_Main_Subprogram and then Bind_Main_Program then
1811 WBI (" __gnat_initialize ((void *)SEH);");
1813 WBI (" __gnat_initialize ((void *)0);");
1817 WBI (" " & Ada_Init_Name.all & " ();");
1819 if not No_Main_Subprogram then
1820 WBI (" __gnat_break_start ();");
1823 -- Output main program name
1825 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
1827 -- Main program is procedure case
1829 if ALIs.Table (ALIs.First).Main_Program = Proc then
1831 Set_Main_Program_Name;
1832 Set_String (" ();");
1833 Write_Statement_Buffer;
1835 -- Main program is function case
1837 else -- ALIs.Table (ALIs_First).Main_Program = Func
1838 Set_String (" result = ");
1839 Set_Main_Program_Name;
1840 Set_String (" ();");
1841 Write_Statement_Buffer;
1846 -- Call adafinal if finalization active
1848 if not Cumulative_Restrictions.Set (No_Finalization) then
1850 WBI (" system__standard_library__adafinal ();");
1853 -- Outputs the dynamic stack measurement if needed
1855 if Dynamic_Stack_Measurement then
1856 WBI (" __gnat_stack_usage_output_results ();");
1859 -- The finalize routine is used only if we have a run-time
1861 if not Suppress_Standard_Library_On_Target then
1862 WBI (" __gnat_finalize ();");
1865 -- Case of main program is a function, so the value it returns
1866 -- is the exit status in this case.
1868 if ALIs.Table (ALIs.First).Main_Program = Func then
1869 if Exit_Status_Supported_On_Target then
1871 -- VMS must use Posix exit routine in order to get the effect
1872 -- of a Unix compatible setting of the program exit status.
1873 -- For all other systems, we use the standard exit routine.
1875 if OpenVMS_On_Target then
1876 WBI (" decc$__posix_exit (result);");
1878 WBI (" exit (result);");
1882 -- Case of main program is a procedure, in which case the exit
1883 -- status is whatever was set by a Set_Exit call most recently
1886 if Exit_Status_Supported_On_Target then
1888 -- VMS must use Posix exit routine in order to get the effect
1889 -- of a Unix compatible setting of the program exit status.
1890 -- For all other systems, we use the standard exit routine.
1892 if OpenVMS_On_Target then
1893 WBI (" decc$__posix_exit (gnat_exit_status);");
1895 WBI (" exit (gnat_exit_status);");
1903 ------------------------------
1904 -- Gen_Object_Files_Options --
1905 ------------------------------
1907 procedure Gen_Object_Files_Options is
1909 -- This keeps track of the position in the sorted set of entries
1910 -- in the Linker_Options table of where the first entry from an
1911 -- internal file appears.
1913 Linker_Option_List_Started : Boolean := False;
1914 -- Set to True when "LINKER OPTION LIST" is displayed
1916 procedure Write_Linker_Option;
1917 -- Write binder info linker option
1919 -------------------------
1920 -- Write_Linker_Option --
1921 -------------------------
1923 procedure Write_Linker_Option is
1928 -- Loop through string, breaking at null's
1931 while Start < Name_Len loop
1933 -- Find null ending this section
1936 while Name_Buffer (Stop) /= ASCII.NUL
1937 and then Stop <= Name_Len loop
1941 -- Process section if non-null
1943 if Stop > Start then
1944 if Output_Linker_Option_List then
1945 if not Zero_Formatting then
1946 if not Linker_Option_List_Started then
1947 Linker_Option_List_Started := True;
1949 Write_Str (" LINKER OPTION LIST");
1957 Write_Str (Name_Buffer (Start .. Stop - 1));
1961 (" -- ", "", Name_Buffer (Start .. Stop - 1));
1966 end Write_Linker_Option;
1968 -- Start of processing for Gen_Object_Files_Options
1972 Write_Info_Ada_C ("-- ", "/* ", " BEGIN Object file/option list");
1974 if Object_List_Filename /= null then
1975 Set_List_File (Object_List_Filename.all);
1978 for E in Elab_Order.First .. Elab_Order.Last loop
1980 -- If not spec that has an associated body, then generate a comment
1981 -- giving the name of the corresponding object file.
1983 if (not Units.Table (Elab_Order.Table (E)).SAL_Interface)
1984 and then Units.Table (Elab_Order.Table (E)).Utype /= Is_Spec
1988 (Units.Table (Elab_Order.Table (E)).My_ALI).Ofile_Full_Name);
1990 -- If the presence of an object file is necessary or if it exists,
1993 if not Hostparm.Exclude_Missing_Objects
1995 System.OS_Lib.Is_Regular_File (Name_Buffer (1 .. Name_Len))
1997 Write_Info_Ada_C (" -- ", "", Name_Buffer (1 .. Name_Len));
1999 if Output_Object_List then
2000 Write_Str (Name_Buffer (1 .. Name_Len));
2004 -- Don't link with the shared library on VMS if an internal
2005 -- filename object is seen. Multiply defined symbols will
2008 if OpenVMS_On_Target
2009 and then Is_Internal_File_Name
2011 (Units.Table (Elab_Order.Table (E)).My_ALI).Sfile)
2013 -- Special case for g-trasym.obj (not included in libgnat)
2015 Get_Name_String (ALIs.Table
2016 (Units.Table (Elab_Order.Table (E)).My_ALI).Sfile);
2018 if Name_Buffer (1 .. 8) /= "g-trasym" then
2019 Opt.Shared_Libgnat := False;
2026 if Object_List_Filename /= null then
2030 -- Add a "-Ldir" for each directory in the object path
2032 for J in 1 .. Nb_Dir_In_Obj_Search_Path loop
2034 Dir : constant String_Ptr := Dir_In_Obj_Search_Path (J);
2037 Add_Str_To_Name_Buffer ("-L");
2038 Add_Str_To_Name_Buffer (Dir.all);
2039 Write_Linker_Option;
2043 -- Sort linker options
2045 -- This sort accomplishes two important purposes:
2047 -- a) All application files are sorted to the front, and all GNAT
2048 -- internal files are sorted to the end. This results in a well
2049 -- defined dividing line between the two sets of files, for the
2050 -- purpose of inserting certain standard library references into
2051 -- the linker arguments list.
2053 -- b) Given two different units, we sort the linker options so that
2054 -- those from a unit earlier in the elaboration order comes later
2055 -- in the list. This is a heuristic designed to create a more
2056 -- friendly order of linker options when the operations appear in
2057 -- separate units. The idea is that if unit A must be elaborated
2058 -- before unit B, then it is more likely that B references
2059 -- libraries included by A, than vice versa, so we want libraries
2060 -- included by A to come after libraries included by B.
2062 -- These two criteria are implemented by function Lt_Linker_Option. Note
2063 -- that a special case of b) is that specs are elaborated before bodies,
2064 -- so linker options from specs come after linker options for bodies,
2065 -- and again, the assumption is that libraries used by the body are more
2066 -- likely to reference libraries used by the spec, than vice versa.
2069 (Linker_Options.Last,
2070 Move_Linker_Option'Access,
2071 Lt_Linker_Option'Access);
2073 -- Write user linker options, i.e. the set of linker options that come
2074 -- from all files other than GNAT internal files, Lgnat is left set to
2075 -- point to the first entry from a GNAT internal file, or past the end
2076 -- of the entriers if there are no internal files.
2078 Lgnat := Linker_Options.Last + 1;
2080 for J in 1 .. Linker_Options.Last loop
2081 if not Linker_Options.Table (J).Internal_File then
2082 Get_Name_String (Linker_Options.Table (J).Name);
2083 Write_Linker_Option;
2090 -- Now we insert standard linker options that must appear after the
2091 -- entries from user files, and before the entries from GNAT run-time
2092 -- files. The reason for this decision is that libraries referenced
2093 -- by internal routines may reference these standard library entries.
2095 -- Note that we do not insert anything when pragma No_Run_Time has been
2096 -- specified or when the standard libraries are not to be used,
2097 -- otherwise on some platforms, such as VMS, we may get duplicate
2098 -- symbols when linking.
2100 if not (Opt.No_Run_Time_Mode or else Opt.No_Stdlib) then
2103 if Opt.Shared_Libgnat then
2104 Add_Str_To_Name_Buffer ("-shared");
2106 Add_Str_To_Name_Buffer ("-static");
2109 -- Write directly to avoid -K output (why???)
2111 Write_Info_Ada_C (" -- ", "", Name_Buffer (1 .. Name_Len));
2113 if With_DECGNAT then
2116 if Opt.Shared_Libgnat then
2117 Add_Str_To_Name_Buffer (Shared_Lib ("decgnat"));
2119 Add_Str_To_Name_Buffer ("-ldecgnat");
2122 Write_Linker_Option;
2128 if Opt.Shared_Libgnat then
2129 Add_Str_To_Name_Buffer (Shared_Lib ("gnarl"));
2131 Add_Str_To_Name_Buffer ("-lgnarl");
2134 Write_Linker_Option;
2139 if Opt.Shared_Libgnat then
2140 Add_Str_To_Name_Buffer (Shared_Lib ("gnat"));
2142 Add_Str_To_Name_Buffer ("-lgnat");
2145 Write_Linker_Option;
2148 -- Write linker options from all internal files
2150 for J in Lgnat .. Linker_Options.Last loop
2151 Get_Name_String (Linker_Options.Table (J).Name);
2152 Write_Linker_Option;
2155 if Output_Linker_Option_List and then not Zero_Formatting then
2159 if Ada_Bind_File then
2160 WBI ("-- END Object file/option list ");
2162 WBI (" END Object file/option list */");
2164 end Gen_Object_Files_Options;
2166 ---------------------
2167 -- Gen_Output_File --
2168 ---------------------
2170 procedure Gen_Output_File (Filename : String) is
2172 -- Acquire settings for Interrupt_State pragmas
2174 Set_IS_Pragma_Table;
2176 -- Acquire settings for Priority_Specific_Dispatching pragma
2178 Set_PSD_Pragma_Table;
2180 -- Override Ada_Bind_File and Bind_Main_Program for VMs since JGNAT only
2181 -- supports Ada code, and the main program is already generated by the
2184 if VM_Target /= No_VM then
2185 Ada_Bind_File := True;
2187 if VM_Target = JVM_Target then
2188 Bind_Main_Program := False;
2192 -- Override time slice value if -T switch is set
2194 if Time_Slice_Set then
2195 ALIs.Table (ALIs.First).Time_Slice_Value := Opt.Time_Slice_Value;
2198 -- Count number of elaboration calls
2200 for E in Elab_Order.First .. Elab_Order.Last loop
2201 if Units.Table (Elab_Order.Table (E)).No_Elab then
2204 Num_Elab_Calls := Num_Elab_Calls + 1;
2208 -- Generate output file in appropriate language
2210 Check_System_Restrictions_Used;
2212 if Ada_Bind_File then
2213 Gen_Output_File_Ada (Filename);
2215 Gen_Output_File_C (Filename);
2217 end Gen_Output_File;
2219 -------------------------
2220 -- Gen_Output_File_Ada --
2221 -------------------------
2223 procedure Gen_Output_File_Ada (Filename : String) is
2226 -- Name of generated bind file (spec)
2229 -- Name of generated bind file (body)
2231 Ada_Main : constant String := Get_Ada_Main_Name;
2232 -- Name to be used for generated Ada main program. See the body of
2233 -- function Get_Ada_Main_Name for details on the form of the name.
2236 -- Create spec first
2238 Create_Binder_Output (Filename, 's', Bfiles);
2240 -- We always compile the binder file in Ada 95 mode so that we properly
2241 -- handle use of Ada 2005 keywords as identifiers in Ada 95 mode. None
2242 -- of the Ada 2005 constructs are needed by the binder file.
2244 WBI ("pragma Ada_95;");
2246 -- If we are operating in Restrictions (No_Exception_Handlers) mode,
2247 -- then we need to make sure that the binder program is compiled with
2248 -- the same restriction, so that no exception tables are generated.
2250 if Cumulative_Restrictions.Set (No_Exception_Handlers) then
2251 WBI ("pragma Restrictions (No_Exception_Handlers);");
2254 -- Same processing for Restrictions (No_Exception_Propagation)
2256 if Cumulative_Restrictions.Set (No_Exception_Propagation) then
2257 WBI ("pragma Restrictions (No_Exception_Propagation);");
2260 -- Same processing for pragma No_Run_Time
2262 if No_Run_Time_Mode then
2263 WBI ("pragma No_Run_Time;");
2266 -- Generate with of System so we can reference System.Address
2268 WBI ("with System;");
2270 -- Generate with of System.Initialize_Scalars if active
2272 if Initialize_Scalars_Used then
2273 WBI ("with System.Scalar_Values;");
2276 -- Generate with of System.Secondary_Stack if active
2278 if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then
2279 WBI ("with System.Secondary_Stack;");
2282 Resolve_Binder_Options;
2284 if VM_Target /= No_VM then
2285 if not Suppress_Standard_Library_On_Target then
2287 -- Usually, adafinal is called using a pragma Import C. Since
2288 -- Import C doesn't have the same semantics for JGNAT, we use
2291 WBI ("with System.Standard_Library;");
2295 WBI ("package " & Ada_Main & " is");
2296 WBI (" pragma Warnings (Off);");
2298 -- Main program case
2300 if Bind_Main_Program then
2301 if VM_Target = No_VM then
2303 -- Generate argc/argv stuff unless suppressed
2305 if Command_Line_Args_On_Target
2306 or not Configurable_Run_Time_On_Target
2309 WBI (" gnat_argc : Integer;");
2310 WBI (" gnat_argv : System.Address;");
2311 WBI (" gnat_envp : System.Address;");
2313 -- If the standard library is not suppressed, these variables
2314 -- are in the run-time data area for easy run time access.
2316 if not Suppress_Standard_Library_On_Target then
2318 WBI (" pragma Import (C, gnat_argc);");
2319 WBI (" pragma Import (C, gnat_argv);");
2320 WBI (" pragma Import (C, gnat_envp);");
2324 -- Define exit status. Again in normal mode, this is in the
2325 -- run-time library, and is initialized there, but in the
2326 -- configurable runtime case, the variable is declared and
2327 -- initialized in this file.
2331 if Configurable_Run_Time_Mode then
2332 if Exit_Status_Supported_On_Target then
2333 WBI (" gnat_exit_status : Integer := 0;");
2337 WBI (" gnat_exit_status : Integer;");
2338 WBI (" pragma Import (C, gnat_exit_status);");
2342 -- Generate the GNAT_Version and Ada_Main_Program_Name info only for
2343 -- the main program. Otherwise, it can lead under some circumstances
2344 -- to a symbol duplication during the link (for instance when a C
2345 -- program uses two Ada libraries). Also zero terminate the string
2346 -- so that its end can be found reliably at run time.
2349 WBI (" GNAT_Version : constant String :=");
2350 WBI (" """ & Ver_Prefix &
2351 Gnat_Version_String &
2353 WBI (" pragma Export (C, GNAT_Version, ""__gnat_version"");");
2356 Set_String (" Ada_Main_Program_Name : constant String := """);
2357 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
2359 if VM_Target = No_VM then
2360 Set_Main_Program_Name;
2361 Set_String (""" & ASCII.NUL;");
2363 Set_String (Name_Buffer (1 .. Name_Len - 2) & """;");
2366 Write_Statement_Buffer;
2369 (" pragma Export (C, Ada_Main_Program_Name, " &
2370 """__gnat_ada_main_program_name"");");
2373 if not Cumulative_Restrictions.Set (No_Finalization) then
2375 WBI (" procedure " & Ada_Final_Name.all & ";");
2376 WBI (" pragma Export (C, " & Ada_Final_Name.all & ", """ &
2377 Ada_Final_Name.all & """);");
2381 WBI (" procedure " & Ada_Init_Name.all & ";");
2382 WBI (" pragma Export (C, " & Ada_Init_Name.all & ", """ &
2383 Ada_Init_Name.all & """);");
2385 -- If -a has been specified use pragma Linker_Constructor for the init
2386 -- procedure. No need to use a similar pragma for the final procedure as
2387 -- global finalization will occur when the executable finishes execution
2388 -- and for plugins (shared stand-alone libraries that can be
2389 -- "unloaded"), finalization should not occur automatically, otherwise
2390 -- the main executable may not continue to work properly.
2392 if Use_Pragma_Linker_Constructor then
2393 WBI (" pragma Linker_Constructor (" & Ada_Init_Name.all & ");");
2396 if Bind_Main_Program and then VM_Target = No_VM then
2398 -- If we have the standard library, then Break_Start is defined
2399 -- there, but when the standard library is suppressed, Break_Start
2403 WBI (" procedure Break_Start;");
2405 if Suppress_Standard_Library_On_Target then
2406 WBI (" pragma Export (C, Break_Start, ""__gnat_break_start"");");
2408 WBI (" pragma Import (C, Break_Start, ""__gnat_break_start"");");
2413 if Exit_Status_Supported_On_Target then
2414 Set_String (" function ");
2416 Set_String (" procedure ");
2419 Set_String (Get_Main_Name);
2421 -- Generate argument list if present
2423 if Command_Line_Args_On_Target then
2424 Write_Statement_Buffer;
2425 WBI (" (argc : Integer;");
2426 WBI (" argv : System.Address;");
2428 (" envp : System.Address)");
2430 if Exit_Status_Supported_On_Target then
2431 Write_Statement_Buffer;
2432 WBI (" return Integer;");
2434 Write_Statement_Buffer (";");
2438 if Exit_Status_Supported_On_Target then
2439 Write_Statement_Buffer (" return Integer;");
2441 Write_Statement_Buffer (";");
2445 WBI (" pragma Export (C, " & Get_Main_Name & ", """ &
2446 Get_Main_Name & """);");
2455 WBI ("end " & Ada_Main & ";");
2456 Close_Binder_Output;
2458 -- Prepare to write body
2460 Create_Binder_Output (Filename, 'b', Bfileb);
2462 -- We always compile the binder file in Ada 95 mode so that we properly
2463 -- handle use of Ada 2005 keywords as identifiers in Ada 95 mode. None
2464 -- of the Ada 2005 constructs are needed by the binder file.
2466 WBI ("pragma Ada_95;");
2468 -- Output Source_File_Name pragmas which look like
2470 -- pragma Source_File_Name (Ada_Main, Spec_File_Name => "sss");
2471 -- pragma Source_File_Name (Ada_Main, Body_File_Name => "bbb");
2473 -- where sss/bbb are the spec/body file names respectively
2475 Get_Name_String (Bfiles);
2476 Name_Buffer (Name_Len + 1 .. Name_Len + 3) := """);";
2478 WBI ("pragma Source_File_Name (" &
2480 ", Spec_File_Name => """ &
2481 Name_Buffer (1 .. Name_Len + 3));
2483 Get_Name_String (Bfileb);
2484 Name_Buffer (Name_Len + 1 .. Name_Len + 3) := """);";
2486 WBI ("pragma Source_File_Name (" &
2488 ", Body_File_Name => """ &
2489 Name_Buffer (1 .. Name_Len + 3));
2491 -- Generate with of System.Restrictions to initialize
2492 -- Run_Time_Restrictions.
2494 if System_Restrictions_Used
2495 and not Suppress_Standard_Library_On_Target
2498 WBI ("with System.Restrictions;");
2502 WBI ("package body " & Ada_Main & " is");
2503 WBI (" pragma Warnings (Off);");
2505 -- Import the finalization procedure only if finalization active
2507 if not Cumulative_Restrictions.Set (No_Finalization) then
2509 -- In the Java case, pragma Import C cannot be used, so the standard
2510 -- Ada constructs will be used instead.
2512 if VM_Target = No_VM then
2514 WBI (" procedure Do_Finalize;");
2516 (" pragma Import (C, Do_Finalize, " &
2517 """system__standard_library__adafinal"");");
2522 if not Suppress_Standard_Library_On_Target then
2524 -- Generate Priority_Specific_Dispatching pragma string
2527 (" Local_Priority_Specific_Dispatching : constant String := """);
2529 for J in 0 .. PSD_Pragma_Settings.Last loop
2530 Set_Char (PSD_Pragma_Settings.Table (J));
2534 Write_Statement_Buffer;
2536 -- Generate Interrupt_State pragma string
2538 Set_String (" Local_Interrupt_States : constant String := """);
2540 for J in 0 .. IS_Pragma_Settings.Last loop
2541 Set_Char (IS_Pragma_Settings.Table (J));
2545 Write_Statement_Buffer;
2551 -- Generate the adafinal routine unless there is no finalization to do
2553 if not Cumulative_Restrictions.Set (No_Finalization) then
2557 if Bind_Main_Program and then VM_Target = No_VM then
2559 -- When suppressing the standard library then generate dummy body
2562 if Suppress_Standard_Library_On_Target then
2564 WBI (" procedure Break_Start is");
2573 -- Output object file list and the Ada body is complete
2575 Gen_Object_Files_Options;
2578 WBI ("end " & Ada_Main & ";");
2580 Close_Binder_Output;
2581 end Gen_Output_File_Ada;
2583 -----------------------
2584 -- Gen_Output_File_C --
2585 -----------------------
2587 procedure Gen_Output_File_C (Filename : String) is
2589 pragma Warnings (Off, Bfile);
2590 -- Name of generated bind file (not referenced)
2593 Create_Binder_Output (Filename, 'c', Bfile);
2595 Resolve_Binder_Options;
2597 WBI ("extern void " & Ada_Final_Name.all & " (void);");
2599 -- If -a has been specified use __attribute__((constructor)) for the
2600 -- init procedure. No need to use a similar featute for the final
2601 -- procedure as global finalization will occur when the executable
2602 -- finishes execution and for plugins (shared stand-alone libraries that
2603 -- can be "unloaded"), finalization should not occur automatically,
2604 -- otherwise the main executable may not continue to work properly.
2606 if Use_Pragma_Linker_Constructor then
2607 WBI ("extern void " & Ada_Init_Name.all &
2608 " (void) __attribute__((constructor));");
2610 WBI ("extern void " & Ada_Init_Name.all & " (void);");
2613 WBI ("extern void system__standard_library__adafinal (void);");
2615 if not No_Main_Subprogram then
2616 Set_String ("extern ");
2618 if Exit_Status_Supported_On_Target then
2621 Set_String ("void");
2624 Set_String (" main ");
2626 if Command_Line_Args_On_Target then
2627 Write_Statement_Buffer ("(int, char **, char **);");
2629 Write_Statement_Buffer ("(void);");
2632 if OpenVMS_On_Target then
2633 WBI ("extern void decc$__posix_exit (int);");
2635 WBI ("extern void exit (int);");
2638 WBI ("extern void __gnat_break_start (void);");
2639 Set_String ("extern ");
2641 if ALIs.Table (ALIs.First).Main_Program = Proc then
2642 Set_String ("void ");
2644 Set_String ("int ");
2647 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
2648 Set_Main_Program_Name;
2649 Set_String (" (void);");
2650 Write_Statement_Buffer;
2653 if not Suppress_Standard_Library_On_Target then
2654 WBI ("extern void __gnat_initialize (void *);");
2655 WBI ("extern void __gnat_finalize (void);");
2656 WBI ("extern void __gnat_install_handler (void);");
2659 if Dynamic_Stack_Measurement then
2661 WBI ("extern void __gnat_stack_usage_output_results (void);");
2662 WBI ("extern void __gnat_stack_usage_initialize (int size);");
2665 -- Initialize stack limit for the environment task if the stack check
2666 -- method is stack limit and stack check is enabled.
2668 if Stack_Check_Limits_On_Target
2669 and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set)
2672 WBI ("extern void __gnat_initialize_stack_limit (void);");
2679 -- Imported variables used only when we have a runtime
2681 if not Suppress_Standard_Library_On_Target then
2683 -- Track elaboration/finalization phase
2685 WBI ("extern int __gnat_handler_installed;");
2688 -- Track feature enable/disable on VMS
2690 if OpenVMS_On_Target then
2691 WBI ("extern int __gnat_features_set;");
2696 -- Write argv/argc exit status stuff if main program case
2698 if Bind_Main_Program then
2700 -- First deal with argc/argv/envp. In the normal case they are in the
2701 -- run-time library.
2703 if not Configurable_Run_Time_On_Target then
2704 WBI ("extern int gnat_argc;");
2705 WBI ("extern char **gnat_argv;");
2706 WBI ("extern char **gnat_envp;");
2708 -- If configurable run time and no command line args, then the
2709 -- generation of these variables is entirely suppressed.
2711 elsif not Command_Line_Args_On_Target then
2714 -- Otherwise, in the configurable run-time case they are right in the
2718 WBI ("int gnat_argc;");
2719 WBI ("char **gnat_argv;");
2720 WBI ("char **gnat_envp;");
2723 -- Similarly deal with exit status
2725 if not Configurable_Run_Time_On_Target then
2726 WBI ("extern int gnat_exit_status;");
2728 -- If configurable run time and no exit status on target, then the
2729 -- generation of this variables is entirely suppressed.
2731 elsif not Exit_Status_Supported_On_Target then
2734 -- Otherwise, in the configurable run-time case this variable is
2735 -- right in the binder file, and initialized to zero there.
2738 WBI ("int gnat_exit_status = 0;");
2744 -- When suppressing the standard library, the __gnat_break_start routine
2745 -- (for the debugger to get initial control) is defined in this file.
2747 if Suppress_Standard_Library_On_Target then
2749 WBI ("void __gnat_break_start (void) {}");
2752 -- Generate the __gnat_version and __gnat_ada_main_program_name info
2753 -- only for the main program. Otherwise, it can lead under some
2754 -- circumstances to a symbol duplication during the link (for instance
2755 -- when a C program uses 2 Ada libraries)
2757 if Bind_Main_Program then
2759 WBI ("char __gnat_version[] = """ & Ver_Prefix &
2760 Gnat_Version_String & """;");
2762 Set_String ("char __gnat_ada_main_program_name[] = """);
2763 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
2764 Set_Main_Program_Name;
2766 Write_Statement_Buffer;
2769 -- Generate the adafinal routine. In no runtime mode, this is not
2770 -- needed, since there is no finalization to do.
2772 if not Cumulative_Restrictions.Set (No_Finalization) then
2778 -- Main is only present for Ada main case
2780 if Bind_Main_Program then
2784 -- Generate versions, elaboration order, list of object files
2788 Gen_Object_Files_Options;
2790 -- C binder output is complete
2792 Close_Binder_Output;
2793 end Gen_Output_File_C;
2795 --------------------------
2796 -- Gen_Restrictions_Ada --
2797 --------------------------
2799 procedure Gen_Restrictions_Ada is
2803 if Suppress_Standard_Library_On_Target
2804 or not System_Restrictions_Used
2809 WBI (" System.Restrictions.Run_Time_Restrictions :=");
2815 for J in Cumulative_Restrictions.Set'Range loop
2816 Set_Boolean (Cumulative_Restrictions.Set (J));
2821 Write_Statement_Buffer;
2827 Set_String_Replace ("),");
2828 Write_Statement_Buffer;
2829 Set_String (" Value => (");
2831 for J in Cumulative_Restrictions.Value'Range loop
2832 Set_Int (Int (Cumulative_Restrictions.Value (J)));
2836 Set_String_Replace ("),");
2837 Write_Statement_Buffer;
2838 WBI (" Violated =>");
2842 for J in Cumulative_Restrictions.Violated'Range loop
2843 Set_Boolean (Cumulative_Restrictions.Violated (J));
2848 Write_Statement_Buffer;
2854 Set_String_Replace ("),");
2855 Write_Statement_Buffer;
2856 Set_String (" Count => (");
2858 for J in Cumulative_Restrictions.Count'Range loop
2859 Set_Int (Int (Cumulative_Restrictions.Count (J)));
2863 Set_String_Replace ("),");
2864 Write_Statement_Buffer;
2865 Set_String (" Unknown => (");
2867 for J in Cumulative_Restrictions.Unknown'Range loop
2868 Set_Boolean (Cumulative_Restrictions.Unknown (J));
2872 Set_String_Replace ("))");
2874 Write_Statement_Buffer;
2875 end Gen_Restrictions_Ada;
2877 ------------------------
2878 -- Gen_Restrictions_C --
2879 ------------------------
2881 procedure Gen_Restrictions_C is
2883 if Suppress_Standard_Library_On_Target
2884 or not System_Restrictions_Used
2889 WBI (" typedef struct {");
2890 Set_String (" char set [");
2891 Set_Int (Cumulative_Restrictions.Set'Length);
2893 Write_Statement_Buffer;
2895 Set_String (" int value [");
2896 Set_Int (Cumulative_Restrictions.Value'Length);
2898 Write_Statement_Buffer;
2900 Set_String (" char violated [");
2901 Set_Int (Cumulative_Restrictions.Violated'Length);
2903 Write_Statement_Buffer;
2905 Set_String (" int count [");
2906 Set_Int (Cumulative_Restrictions.Count'Length);
2908 Write_Statement_Buffer;
2910 Set_String (" char unknown [");
2911 Set_Int (Cumulative_Restrictions.Unknown'Length);
2913 Write_Statement_Buffer;
2914 WBI (" } restrictions;");
2915 WBI (" extern restrictions " &
2916 "system__restrictions__run_time_restrictions;");
2917 WBI (" restrictions r = {");
2920 for J in Cumulative_Restrictions.Set'Range loop
2921 Set_Int (Boolean'Pos (Cumulative_Restrictions.Set (J)));
2925 Set_String_Replace ("},");
2926 Write_Statement_Buffer;
2929 for J in Cumulative_Restrictions.Value'Range loop
2930 Set_Int (Int (Cumulative_Restrictions.Value (J)));
2934 Set_String_Replace ("},");
2935 Write_Statement_Buffer;
2938 for J in Cumulative_Restrictions.Violated'Range loop
2939 Set_Int (Boolean'Pos (Cumulative_Restrictions.Violated (J)));
2943 Set_String_Replace ("},");
2944 Write_Statement_Buffer;
2947 for J in Cumulative_Restrictions.Count'Range loop
2948 Set_Int (Int (Cumulative_Restrictions.Count (J)));
2952 Set_String_Replace ("},");
2953 Write_Statement_Buffer;
2956 for J in Cumulative_Restrictions.Unknown'Range loop
2957 Set_Int (Boolean'Pos (Cumulative_Restrictions.Unknown (J)));
2961 Set_String_Replace ("}}");
2963 Write_Statement_Buffer;
2964 WBI (" system__restrictions__run_time_restrictions = r;");
2965 end Gen_Restrictions_C;
2967 ----------------------
2968 -- Gen_Versions_Ada --
2969 ----------------------
2971 -- This routine generates lines such as:
2973 -- unnnnn : constant Integer := 16#hhhhhhhh#;
2974 -- pragma Export (C, unnnnn, unam);
2976 -- for each unit, where unam is the unit name suffixed by either B or S for
2977 -- body or spec, with dots replaced by double underscores, and hhhhhhhh is
2978 -- the version number, and nnnnn is a 5-digits serial number.
2980 procedure Gen_Versions_Ada is
2981 Ubuf : String (1 .. 6) := "u00000";
2983 procedure Increment_Ubuf;
2984 -- Little procedure to increment the serial number
2986 procedure Increment_Ubuf is
2988 for J in reverse Ubuf'Range loop
2989 Ubuf (J) := Character'Succ (Ubuf (J));
2990 exit when Ubuf (J) <= '9';
2995 -- Start of processing for Gen_Versions_Ada
3000 WBI (" type Version_32 is mod 2 ** 32;");
3001 for U in Units.First .. Units.Last loop
3002 if not Units.Table (U).SAL_Interface and then
3003 ((not Bind_For_Library) or else Units.Table (U).Directly_Scanned)
3006 WBI (" " & Ubuf & " : constant Version_32 := 16#" &
3007 Units.Table (U).Version & "#;");
3008 Set_String (" pragma Export (C, ");
3010 Set_String (", """);
3012 Get_Name_String (Units.Table (U).Uname);
3014 for K in 1 .. Name_Len loop
3015 if Name_Buffer (K) = '.' then
3019 elsif Name_Buffer (K) = '%' then
3023 Set_Char (Name_Buffer (K));
3027 if Name_Buffer (Name_Len) = 's' then
3033 Set_String (""");");
3034 Write_Statement_Buffer;
3038 end Gen_Versions_Ada;
3040 --------------------
3041 -- Gen_Versions_C --
3042 --------------------
3044 -- This routine generates a line of the form:
3046 -- unsigned unam = 0xhhhhhhhh;
3048 -- for each unit, where unam is the unit name suffixed by either B or S for
3049 -- body or spec, with dots replaced by double underscores.
3051 procedure Gen_Versions_C is
3053 for U in Units.First .. Units.Last loop
3054 if not Units.Table (U).SAL_Interface and then
3055 ((not Bind_For_Library) or else Units.Table (U).Directly_Scanned)
3057 Set_String ("unsigned ");
3059 Get_Name_String (Units.Table (U).Uname);
3061 for K in 1 .. Name_Len loop
3062 if Name_Buffer (K) = '.' then
3065 elsif Name_Buffer (K) = '%' then
3069 Set_Char (Name_Buffer (K));
3073 if Name_Buffer (Name_Len) = 's' then
3079 Set_String (" = 0x");
3080 Set_String (Units.Table (U).Version);
3082 Write_Statement_Buffer;
3088 ------------------------
3089 -- Get_Main_Unit_Name --
3090 ------------------------
3092 function Get_Main_Unit_Name (S : String) return String is
3093 Result : String := S;
3096 for J in S'Range loop
3097 if Result (J) = '.' then
3103 end Get_Main_Unit_Name;
3105 -----------------------
3106 -- Get_Ada_Main_Name --
3107 -----------------------
3109 function Get_Ada_Main_Name return String is
3110 Suffix : constant String := "_00";
3111 Name : String (1 .. Opt.Ada_Main_Name.all'Length + Suffix'Length) :=
3112 Opt.Ada_Main_Name.all & Suffix;
3116 -- The main program generated by JGNAT expects a package called
3117 -- ada_<main procedure>.
3119 if VM_Target /= No_VM then
3120 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
3121 return "ada_" & Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len - 2));
3124 -- This loop tries the following possibilities in order
3130 -- where <Ada_Main> is equal to Opt.Ada_Main_Name. By default,
3131 -- it is set to 'ada_main'.
3133 for J in 0 .. 99 loop
3135 Nlen := Name'Length - Suffix'Length;
3137 Nlen := Name'Length;
3138 Name (Name'Last) := Character'Val (J mod 10 + Character'Pos ('0'));
3139 Name (Name'Last - 1) :=
3140 Character'Val (J / 10 + Character'Pos ('0'));
3143 for K in ALIs.First .. ALIs.Last loop
3144 for L in ALIs.Table (K).First_Unit .. ALIs.Table (K).Last_Unit loop
3146 -- Get unit name, removing %b or %e at end
3148 Get_Name_String (Units.Table (L).Uname);
3149 Name_Len := Name_Len - 2;
3151 if Name_Buffer (1 .. Name_Len) = Name (1 .. Nlen) then
3157 return Name (1 .. Nlen);
3163 -- If we fall through, just use a peculiar unlikely name
3165 return ("Qwertyuiop");
3166 end Get_Ada_Main_Name;
3172 function Get_Main_Name return String is
3174 -- Explicit name given with -M switch
3176 if Bind_Alternate_Main_Name then
3177 return Alternate_Main_Name.all;
3179 -- Case of main program name to be used directly
3181 elsif Use_Ada_Main_Program_Name_On_Target then
3183 -- Get main program name
3185 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
3187 -- If this is a child name, return only the name of the child, since
3188 -- we can't have dots in a nested program name. Note that we do not
3189 -- include the %b at the end of the unit name.
3191 for J in reverse 1 .. Name_Len - 2 loop
3192 if J = 1 or else Name_Buffer (J - 1) = '.' then
3193 return Name_Buffer (J .. Name_Len - 2);
3197 raise Program_Error; -- impossible exit
3199 -- Case where "main" is to be used as default
3206 ---------------------
3207 -- Get_WC_Encoding --
3208 ---------------------
3210 function Get_WC_Encoding return Character is
3212 -- If encoding method specified by -W switch, then return it
3214 if Wide_Character_Encoding_Method_Specified then
3215 return WC_Encoding_Letters (Wide_Character_Encoding_Method);
3217 -- If no main program, and not specified, set brackets, we really have
3218 -- no better choice. If some other encoding is required when there is
3219 -- no main, it must be set explicitly using -Wx.
3221 -- Note: if the ALI file always passed the wide character encoding of
3222 -- every file, then we could use the encoding of the initial specified
3223 -- file, but this information is passed only for potential main
3224 -- programs. We could fix this sometime, but it is a very minor point
3225 -- (wide character default encoding for [Wide_[Wide_]Text_IO when there
3226 -- is no main program).
3228 elsif No_Main_Subprogram then
3231 -- Otherwise if there is a main program, take encoding from it
3234 return ALIs.Table (ALIs.First).WC_Encoding;
3236 end Get_WC_Encoding;
3238 ----------------------
3239 -- Lt_Linker_Option --
3240 ----------------------
3242 function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean is
3244 -- Sort internal files last
3246 if Linker_Options.Table (Op1).Internal_File
3248 Linker_Options.Table (Op2).Internal_File
3250 -- Note: following test uses False < True
3252 return Linker_Options.Table (Op1).Internal_File
3254 Linker_Options.Table (Op2).Internal_File;
3256 -- If both internal or both non-internal, sort according to the
3257 -- elaboration position. A unit that is elaborated later should come
3258 -- earlier in the linker options list.
3261 return Units.Table (Linker_Options.Table (Op1).Unit).Elab_Position
3263 Units.Table (Linker_Options.Table (Op2).Unit).Elab_Position;
3266 end Lt_Linker_Option;
3268 ------------------------
3269 -- Move_Linker_Option --
3270 ------------------------
3272 procedure Move_Linker_Option (From : Natural; To : Natural) is
3274 Linker_Options.Table (To) := Linker_Options.Table (From);
3275 end Move_Linker_Option;
3277 ----------------------------
3278 -- Resolve_Binder_Options --
3279 ----------------------------
3281 procedure Resolve_Binder_Options is
3283 for E in Elab_Order.First .. Elab_Order.Last loop
3284 Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
3286 -- This is not a perfect approach, but is the current protocol
3287 -- between the run-time and the binder to indicate that tasking is
3288 -- used: system.os_interface should always be used by any tasking
3291 if Name_Buffer (1 .. 19) = "system.os_interface" then
3295 -- Ditto for declib and the "dec" package
3297 if OpenVMS_On_Target and then Name_Buffer (1 .. 5) = "dec%s" then
3298 With_DECGNAT := True;
3301 end Resolve_Binder_Options;
3307 procedure Set_Boolean (B : Boolean) is
3308 True_Str : constant String := "True";
3309 False_Str : constant String := "False";
3312 Statement_Buffer (Last + 1 .. Last + True_Str'Length) := True_Str;
3313 Last := Last + True_Str'Length;
3315 Statement_Buffer (Last + 1 .. Last + False_Str'Length) := False_Str;
3316 Last := Last + False_Str'Length;
3324 procedure Set_Char (C : Character) is
3327 Statement_Buffer (Last) := C;
3334 procedure Set_Int (N : Int) is
3346 Statement_Buffer (Last) :=
3347 Character'Val (N mod 10 + Character'Pos ('0'));
3351 -------------------------
3352 -- Set_IS_Pragma_Table --
3353 -------------------------
3355 procedure Set_IS_Pragma_Table is
3357 for F in ALIs.First .. ALIs.Last loop
3358 for K in ALIs.Table (F).First_Interrupt_State ..
3359 ALIs.Table (F).Last_Interrupt_State
3362 Inum : constant Int :=
3363 Interrupt_States.Table (K).Interrupt_Id;
3364 Stat : constant Character :=
3365 Interrupt_States.Table (K).Interrupt_State;
3368 while IS_Pragma_Settings.Last < Inum loop
3369 IS_Pragma_Settings.Append ('n');
3372 IS_Pragma_Settings.Table (Inum) := Stat;
3376 end Set_IS_Pragma_Table;
3378 ---------------------------
3379 -- Set_Main_Program_Name --
3380 ---------------------------
3382 procedure Set_Main_Program_Name is
3384 -- Note that name has %b on the end which we ignore
3386 -- First we output the initial _ada_ since we know that the main
3387 -- program is a library level subprogram.
3389 Set_String ("_ada_");
3391 -- Copy name, changing dots to double underscores
3393 for J in 1 .. Name_Len - 2 loop
3394 if Name_Buffer (J) = '.' then
3397 Set_Char (Name_Buffer (J));
3400 end Set_Main_Program_Name;
3402 ---------------------
3403 -- Set_Name_Buffer --
3404 ---------------------
3406 procedure Set_Name_Buffer is
3408 for J in 1 .. Name_Len loop
3409 Set_Char (Name_Buffer (J));
3411 end Set_Name_Buffer;
3413 -------------------------
3414 -- Set_PSD_Pragma_Table --
3415 -------------------------
3417 procedure Set_PSD_Pragma_Table is
3419 for F in ALIs.First .. ALIs.Last loop
3420 for K in ALIs.Table (F).First_Specific_Dispatching ..
3421 ALIs.Table (F).Last_Specific_Dispatching
3424 DTK : Specific_Dispatching_Record
3425 renames Specific_Dispatching.Table (K);
3428 while PSD_Pragma_Settings.Last < DTK.Last_Priority loop
3429 PSD_Pragma_Settings.Append ('F');
3432 for Prio in DTK.First_Priority .. DTK.Last_Priority loop
3433 PSD_Pragma_Settings.Table (Prio) := DTK.Dispatching_Policy;
3438 end Set_PSD_Pragma_Table;
3444 procedure Set_String (S : String) is
3446 Statement_Buffer (Last + 1 .. Last + S'Length) := S;
3447 Last := Last + S'Length;
3450 ------------------------
3451 -- Set_String_Replace --
3452 ------------------------
3454 procedure Set_String_Replace (S : String) is
3456 Statement_Buffer (Last - S'Length + 1 .. Last) := S;
3457 end Set_String_Replace;
3463 procedure Set_Unit_Name is
3465 for J in 1 .. Name_Len - 2 loop
3466 if Name_Buffer (J) /= '.' then
3467 Set_Char (Name_Buffer (J));
3474 ---------------------
3475 -- Set_Unit_Number --
3476 ---------------------
3478 procedure Set_Unit_Number (U : Unit_Id) is
3479 Num_Units : constant Nat := Nat (Units.Last) - Nat (Unit_Id'First);
3480 Unum : constant Nat := Nat (U) - Nat (Unit_Id'First);
3483 if Num_Units >= 10 and then Unum < 10 then
3487 if Num_Units >= 100 and then Unum < 100 then
3492 end Set_Unit_Number;
3494 ----------------------
3495 -- Write_Info_Ada_C --
3496 ----------------------
3498 procedure Write_Info_Ada_C (Ada : String; C : String; Common : String) is
3500 if Ada_Bind_File then
3502 S : String (1 .. Ada'Length + Common'Length);
3504 S (1 .. Ada'Length) := Ada;
3505 S (Ada'Length + 1 .. S'Length) := Common;
3511 S : String (1 .. C'Length + Common'Length);
3513 S (1 .. C'Length) := C;
3514 S (C'Length + 1 .. S'Length) := Common;
3518 end Write_Info_Ada_C;
3520 ----------------------------
3521 -- Write_Statement_Buffer --
3522 ----------------------------
3524 procedure Write_Statement_Buffer is
3526 WBI (Statement_Buffer (1 .. Last));
3528 end Write_Statement_Buffer;
3530 procedure Write_Statement_Buffer (S : String) is
3533 Write_Statement_Buffer;
3534 end Write_Statement_Buffer;