1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2011, 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 Lib_Final_Built : Boolean := False;
75 -- Flag indicating whether the finalize_library rountine has been built
77 ----------------------------------
78 -- Interface_State Pragma Table --
79 ----------------------------------
81 -- This table assembles the interface state pragma information from
82 -- all the units in the partition. Note that Bcheck has already checked
83 -- that the information is consistent across units. The entries
84 -- in this table are n/u/r/s for not set/user/runtime/system.
86 package IS_Pragma_Settings is new Table.Table (
87 Table_Component_Type => Character,
88 Table_Index_Type => Int,
91 Table_Increment => 200,
92 Table_Name => "IS_Pragma_Settings");
94 -- This table assembles the Priority_Specific_Dispatching pragma
95 -- information from all the units in the partition. Note that Bcheck has
96 -- already checked that the information is consistent across units.
97 -- The entries in this table are the upper case first character of the
98 -- policy name, e.g. 'F' for FIFO_Within_Priorities.
100 package PSD_Pragma_Settings is new Table.Table (
101 Table_Component_Type => Character,
102 Table_Index_Type => Int,
103 Table_Low_Bound => 0,
104 Table_Initial => 100,
105 Table_Increment => 200,
106 Table_Name => "PSD_Pragma_Settings");
108 ----------------------
109 -- Run-Time Globals --
110 ----------------------
112 -- This section documents the global variables that set from the
113 -- generated binder file.
115 -- Main_Priority : Integer;
116 -- Time_Slice_Value : Integer;
117 -- Heap_Size : Natural;
118 -- WC_Encoding : Character;
119 -- Locking_Policy : Character;
120 -- Queuing_Policy : Character;
121 -- Task_Dispatching_Policy : Character;
122 -- Priority_Specific_Dispatching : System.Address;
123 -- Num_Specific_Dispatching : Integer;
124 -- Restrictions : System.Address;
125 -- Interrupt_States : System.Address;
126 -- Num_Interrupt_States : Integer;
127 -- Unreserve_All_Interrupts : Integer;
128 -- Exception_Tracebacks : Integer;
129 -- Zero_Cost_Exceptions : Integer;
130 -- Detect_Blocking : Integer;
131 -- Default_Stack_Size : Integer;
132 -- Leap_Seconds_Support : Integer;
133 -- Main_CPU : Integer;
135 -- Main_Priority is the priority value set by pragma Priority in the main
136 -- program. If no such pragma is present, the value is -1.
138 -- Time_Slice_Value is the time slice value set by pragma Time_Slice in the
139 -- main program, or by the use of a -Tnnn parameter for the binder (if both
140 -- are present, the binder value overrides). The value is in milliseconds.
141 -- A value of zero indicates that time slicing should be suppressed. If no
142 -- pragma is present, and no -T switch was used, the value is -1.
144 -- Heap_Size is the heap to use for memory allocations set by use of a
145 -- -Hnn parameter for the binder or by the GNAT$NO_MALLOC_64 logical.
146 -- Valid values are 32 and 64. This switch is only effective on VMS.
148 -- WC_Encoding shows the wide character encoding method used for the main
149 -- program. This is one of the encoding letters defined in
150 -- System.WCh_Con.WC_Encoding_Letters.
152 -- Locking_Policy is a space if no locking policy was specified for the
153 -- partition. If a locking policy was specified, the value is the upper
154 -- case first character of the locking policy name, for example, 'C' for
157 -- Queuing_Policy is a space if no queuing policy was specified for the
158 -- partition. If a queuing policy was specified, the value is the upper
159 -- case first character of the queuing policy name for example, 'F' for
162 -- Task_Dispatching_Policy is a space if no task dispatching policy was
163 -- specified for the partition. If a task dispatching policy was specified,
164 -- the value is the upper case first character of the policy name, e.g. 'F'
165 -- for FIFO_Within_Priorities.
167 -- Priority_Specific_Dispatching is the address of a string used to store
168 -- the task dispatching policy specified for the different priorities in
169 -- the partition. The length of this string is determined by the last
170 -- priority for which such a pragma applies (the string will be a null
171 -- string if no specific dispatching policies were used). If pragma were
172 -- present, the entries apply to the priorities in sequence from the first
173 -- priority. The value stored is the upper case first character of the
174 -- policy name, or 'F' (for FIFO_Within_Priorities) as the default value
175 -- for those priority ranges not specified.
177 -- Num_Specific_Dispatching is the length of the
178 -- Priority_Specific_Dispatching string. It will be set to zero if no
179 -- Priority_Specific_Dispatching pragmas are present.
181 -- Restrictions is the address of a null-terminated string specifying the
182 -- restrictions information for the partition. The format is identical to
183 -- that of the parameter string found on R lines in ali files (see Lib.Writ
184 -- spec in lib-writ.ads for full details). The difference is that in this
185 -- context the values are the cumulative ones for the entire partition.
187 -- Interrupt_States is the address of a string used to specify the
188 -- cumulative results of Interrupt_State pragmas used in the partition.
189 -- The length of this string is determined by the last interrupt for which
190 -- such a pragma is given (the string will be a null string if no pragmas
191 -- were used). If pragma were present the entries apply to the interrupts
192 -- in sequence from the first interrupt, and are set to one of four
193 -- possible settings: 'n' for not specified, 'u' for user, 'r' for run
194 -- time, 's' for system, see description of Interrupt_State pragma for
197 -- Num_Interrupt_States is the length of the Interrupt_States string. It
198 -- will be set to zero if no Interrupt_State pragmas are present.
200 -- Unreserve_All_Interrupts is set to one if at least one unit in the
201 -- partition had a pragma Unreserve_All_Interrupts, and zero otherwise.
203 -- Exception_Tracebacks is set to one if the -E parameter was present
204 -- in the bind and to zero otherwise. Note that on some targets exception
205 -- tracebacks are provided by default, so a value of zero for this
206 -- parameter does not necessarily mean no trace backs are available.
208 -- Zero_Cost_Exceptions is set to one if zero cost exceptions are used for
209 -- this partition, and to zero if longjmp/setjmp exceptions are used.
211 -- Detect_Blocking indicates whether pragma Detect_Blocking is active or
212 -- not. A value of zero indicates that the pragma is not present, while a
213 -- value of 1 signals its presence in the partition.
215 -- Default_Stack_Size is the default stack size used when creating an Ada
216 -- task with no explicit Storage_Size clause.
218 -- Leap_Seconds_Support denotes whether leap seconds have been enabled or
219 -- disabled. A value of zero indicates that leap seconds are turned "off",
220 -- while a value of one signifies "on" status.
222 -- Main_CPU is the processor set by pragma CPU in the main program. If no
223 -- such pragma is present, the value is -1.
225 -----------------------
226 -- Local Subprograms --
227 -----------------------
229 procedure WBI (Info : String) renames Osint.B.Write_Binder_Info;
230 -- Convenient shorthand used throughout
232 procedure Check_System_Restrictions_Used;
233 -- Sets flag System_Restrictions_Used (Set to True if and only if the unit
234 -- System.Restrictions is present in the partition, otherwise False).
236 procedure Gen_Adainit_Ada;
237 -- Generates the Adainit procedure (Ada code case)
239 procedure Gen_Adainit_C;
240 -- Generates the Adainit procedure (C code case)
242 procedure Gen_Adafinal_Ada;
243 -- Generate the Adafinal procedure (Ada code case)
245 procedure Gen_Adafinal_C;
246 -- Generate the Adafinal procedure (C code case)
248 procedure Gen_Elab_Externals_Ada;
249 -- Generate sequence of external declarations for elaboration (Ada)
251 procedure Gen_Elab_Externals_C;
252 -- Generate sequence of external declarations for elaboration (C)
254 procedure Gen_Elab_Calls_Ada;
255 -- Generate sequence of elaboration calls (Ada code case)
257 procedure Gen_Elab_Calls_C;
258 -- Generate sequence of elaboration calls (C code case)
260 procedure Gen_Elab_Order_Ada;
261 -- Generate comments showing elaboration order chosen (Ada code case)
263 procedure Gen_Elab_Order_C;
264 -- Generate comments showing elaboration order chosen (C code case)
266 procedure Gen_Elab_Defs_C;
267 -- Generate sequence of definitions for elaboration routines (C code case)
269 procedure Gen_Finalize_Library_Ada;
270 -- Generate a sequence of finalization calls to elaborated packages (Ada)
272 procedure Gen_Finalize_Library_C;
273 -- Generate a sequence of finalization calls to elaborated packages (C)
275 procedure Gen_Finalize_Library_Defs_C;
276 -- Generate a sequence of defininitions for package finalizers (C case)
278 procedure Gen_Main_Ada;
279 -- Generate procedure main (Ada code case)
281 procedure Gen_Main_C;
282 -- Generate main() procedure (C code case)
284 procedure Gen_Object_Files_Options;
285 -- Output comments containing a list of the full names of the object
286 -- files to be linked and the list of linker options supplied by
287 -- Linker_Options pragmas in the source. (C and Ada code case)
289 procedure Gen_Output_File_Ada (Filename : String);
290 -- Generate output file (Ada code case)
292 procedure Gen_Output_File_C (Filename : String);
293 -- Generate output file (C code case)
295 procedure Gen_Restrictions_Ada;
296 -- Generate initialization of restrictions variable (Ada code case)
298 procedure Gen_Restrictions_C;
299 -- Generate initialization of restrictions variable (C code case)
301 procedure Gen_Versions_Ada;
302 -- Output series of definitions for unit versions (Ada code case)
304 procedure Gen_Versions_C;
305 -- Output series of definitions for unit versions (C code case)
307 function Get_Ada_Main_Name return String;
308 -- This function is used in the Ada main output case to compute a usable
309 -- name for the generated main program. The normal main program name is
310 -- Ada_Main, but this won't work if the user has a unit with this name.
311 -- This function tries Ada_Main first, and if there is such a clash, then
312 -- it tries Ada_Name_01, Ada_Name_02 ... Ada_Name_99 in sequence.
314 function Get_Main_Unit_Name (S : String) return String;
315 -- Return the main unit name corresponding to S by replacing '.' with '_'
317 function Get_Main_Name return String;
318 -- This function is used in the Ada main output case to compute the
319 -- correct external main program. It is "main" by default, unless the
320 -- flag Use_Ada_Main_Program_Name_On_Target is set, in which case it
321 -- is the name of the Ada main name without the "_ada". This default
322 -- can be overridden explicitly using the -Mname binder switch.
324 function Get_WC_Encoding return Character;
325 -- Return wide character encoding method to set as WC_Encoding in output.
326 -- If -W has been used, returns the specified encoding, otherwise returns
327 -- the encoding method used for the main program source. If there is no
328 -- main program source (-z switch used), returns brackets ('b').
330 function Has_Finalizer return Boolean;
331 -- Determine whether the current unit has at least one library-level
334 function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean;
335 -- Compare linker options, when sorting, first according to
336 -- Is_Internal_File (internal files come later) and then by
337 -- elaboration order position (latest to earliest).
339 procedure Move_Linker_Option (From : Natural; To : Natural);
340 -- Move routine for sorting linker options
342 procedure Resolve_Binder_Options;
343 -- Set the value of With_GNARL and With_DECGNAT. The latter only on VMS
344 -- since it tests for a package named "dec" which might cause a conflict
345 -- on non-VMS systems.
347 procedure Set_Char (C : Character);
348 -- Set given character in Statement_Buffer at the Last + 1 position
349 -- and increment Last by one to reflect the stored character.
351 procedure Set_Int (N : Int);
352 -- Set given value in decimal in Statement_Buffer with no spaces
353 -- starting at the Last + 1 position, and updating Last past the value.
354 -- A minus sign is output for a negative value.
356 procedure Set_Boolean (B : Boolean);
357 -- Set given boolean value in Statement_Buffer at the Last + 1 position
358 -- and update Last past the value.
360 procedure Set_IS_Pragma_Table;
361 -- Initializes contents of IS_Pragma_Settings table from ALI table
363 procedure Set_Main_Program_Name;
364 -- Given the main program name in Name_Buffer (length in Name_Len)
365 -- generate the name of the routine to be used in the call. The name
366 -- is generated starting at Last + 1, and Last is updated past it.
368 procedure Set_Name_Buffer;
369 -- Set the value stored in positions 1 .. Name_Len of the Name_Buffer
371 procedure Set_PSD_Pragma_Table;
372 -- Initializes contents of PSD_Pragma_Settings table from ALI table
374 procedure Set_String (S : String);
375 -- Sets characters of given string in Statement_Buffer, starting at the
376 -- Last + 1 position, and updating last past the string value.
378 procedure Set_String_Replace (S : String);
379 -- Replaces the last S'Length characters in the Statement_Buffer with
380 -- the characters of S. The caller must ensure that these characters do
381 -- in fact exist in the Statement_Buffer.
383 type Qualification_Mode is (Dollar_Sign, Dot, Double_Underscores);
385 procedure Set_Unit_Name (Mode : Qualification_Mode := Double_Underscores);
386 -- Given a unit name in the Name_Buffer, copy it into Statement_Buffer,
387 -- starting at the Last + 1 position and update Last past the value.
388 -- Depending on parameter Mode, a dot (.) can be qualified into double
389 -- underscores (__), a dollar sign ($) or left as is.
391 procedure Set_Unit_Number (U : Unit_Id);
392 -- Sets unit number (first unit is 1, leading zeroes output to line
393 -- up all output unit numbers nicely as required by the value, and
394 -- by the total number of units.
396 procedure Write_Info_Ada_C (Ada : String; C : String; Common : String);
397 -- For C code case, write C & Common, for Ada case write Ada & Common
398 -- to current binder output file using Write_Binder_Info.
400 procedure Write_Statement_Buffer;
401 -- Write out contents of statement buffer up to Last, and reset Last to 0
403 procedure Write_Statement_Buffer (S : String);
404 -- First writes its argument (using Set_String (S)), then writes out the
405 -- contents of statement buffer up to Last, and reset Last to 0
407 ------------------------------------
408 -- Check_System_Restrictions_Used --
409 ------------------------------------
411 procedure Check_System_Restrictions_Used is
413 for J in Units.First .. Units.Last loop
414 if Get_Name_String (Units.Table (J).Sfile) = "s-restri.ads" then
415 System_Restrictions_Used := True;
420 System_Restrictions_Used := False;
421 end Check_System_Restrictions_Used;
423 ----------------------
424 -- Gen_Adafinal_Ada --
425 ----------------------
427 procedure Gen_Adafinal_Ada is
429 WBI (" procedure " & Ada_Final_Name.all & " is");
431 if not Bind_Main_Program then
433 if Lib_Final_Built then
434 WBI (" finalize_library;");
441 elsif VM_Target = No_VM then
442 WBI (" procedure s_stalib_adafinal;");
443 WBI (" pragma Import (C, s_stalib_adafinal, " &
444 """system__standard_library__adafinal"");");
446 WBI (" s_stalib_adafinal;");
448 -- Pragma Import C cannot be used on virtual machine targets, therefore
449 -- call the runtime finalization routine directly.
453 WBI (" System.Standard_Library.Adafinal;");
456 WBI (" end " & Ada_Final_Name.all & ";");
458 end Gen_Adafinal_Ada;
464 procedure Gen_Adafinal_C is
466 WBI ("void " & Ada_Final_Name.all & " (void) {");
468 if not Bind_Main_Program then
469 if Lib_Final_Built then
470 WBI (" finalize_library ();");
476 WBI (" system__standard_library__adafinal ();");
482 ---------------------
483 -- Gen_Adainit_Ada --
484 ---------------------
486 procedure Gen_Adainit_Ada is
487 Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority;
488 Main_CPU : Int renames ALIs.Table (ALIs.First).Main_CPU;
491 WBI (" procedure " & Ada_Init_Name.all & " is");
493 -- If the standard library is suppressed, then the only global variables
494 -- that might be needed (by the Ravenscar profile) are the priority and
495 -- the processor for the environment task.
497 if Suppress_Standard_Library_On_Target then
498 if Main_Priority /= No_Main_Priority then
499 WBI (" Main_Priority : Integer;");
500 WBI (" pragma Import (C, Main_Priority," &
501 " ""__gl_main_priority"");");
505 if Main_CPU /= No_Main_CPU then
506 WBI (" Main_CPU : Integer;");
507 WBI (" pragma Import (C, Main_CPU," &
508 " ""__gl_main_cpu"");");
514 if Main_Priority /= No_Main_Priority then
515 Set_String (" Main_Priority := ");
516 Set_Int (Main_Priority);
518 Write_Statement_Buffer;
521 if Main_CPU /= No_Main_CPU then
522 Set_String (" Main_CPU := ");
525 Write_Statement_Buffer;
528 if Main_Priority = No_Main_Priority
529 and then Main_CPU = No_Main_CPU
534 -- Normal case (standard library not suppressed). Set all global values
535 -- used by the run time.
538 WBI (" Main_Priority : Integer;");
539 WBI (" pragma Import (C, Main_Priority, " &
540 """__gl_main_priority"");");
541 WBI (" Time_Slice_Value : Integer;");
542 WBI (" pragma Import (C, Time_Slice_Value, " &
543 """__gl_time_slice_val"");");
544 WBI (" WC_Encoding : Character;");
545 WBI (" pragma Import (C, WC_Encoding, ""__gl_wc_encoding"");");
546 WBI (" Locking_Policy : Character;");
547 WBI (" pragma Import (C, Locking_Policy, " &
548 """__gl_locking_policy"");");
549 WBI (" Queuing_Policy : Character;");
550 WBI (" pragma Import (C, Queuing_Policy, " &
551 """__gl_queuing_policy"");");
552 WBI (" Task_Dispatching_Policy : Character;");
553 WBI (" pragma Import (C, Task_Dispatching_Policy, " &
554 """__gl_task_dispatching_policy"");");
555 WBI (" Priority_Specific_Dispatching : System.Address;");
556 WBI (" pragma Import (C, Priority_Specific_Dispatching, " &
557 """__gl_priority_specific_dispatching"");");
558 WBI (" Num_Specific_Dispatching : Integer;");
559 WBI (" pragma Import (C, Num_Specific_Dispatching, " &
560 """__gl_num_specific_dispatching"");");
561 WBI (" Main_CPU : Integer;");
562 WBI (" pragma Import (C, Main_CPU, " &
563 """__gl_main_cpu"");");
565 WBI (" Interrupt_States : System.Address;");
566 WBI (" pragma Import (C, Interrupt_States, " &
567 """__gl_interrupt_states"");");
568 WBI (" Num_Interrupt_States : Integer;");
569 WBI (" pragma Import (C, Num_Interrupt_States, " &
570 """__gl_num_interrupt_states"");");
571 WBI (" Unreserve_All_Interrupts : Integer;");
572 WBI (" pragma Import (C, Unreserve_All_Interrupts, " &
573 """__gl_unreserve_all_interrupts"");");
575 if Exception_Tracebacks then
576 WBI (" Exception_Tracebacks : Integer;");
577 WBI (" pragma Import (C, Exception_Tracebacks, " &
578 """__gl_exception_tracebacks"");");
581 WBI (" Zero_Cost_Exceptions : Integer;");
582 WBI (" pragma Import (C, Zero_Cost_Exceptions, " &
583 """__gl_zero_cost_exceptions"");");
584 WBI (" Detect_Blocking : Integer;");
585 WBI (" pragma Import (C, Detect_Blocking, " &
586 """__gl_detect_blocking"");");
587 WBI (" Default_Stack_Size : Integer;");
588 WBI (" pragma Import (C, Default_Stack_Size, " &
589 """__gl_default_stack_size"");");
590 WBI (" Leap_Seconds_Support : Integer;");
591 WBI (" pragma Import (C, Leap_Seconds_Support, " &
592 """__gl_leap_seconds_support"");");
594 -- Import entry point for elaboration time signal handler
595 -- installation, and indication of if it's been called previously.
598 WBI (" procedure Install_Handler;");
599 WBI (" pragma Import (C, Install_Handler, " &
600 """__gnat_install_handler"");");
602 WBI (" Handler_Installed : Integer;");
603 WBI (" pragma Import (C, Handler_Installed, " &
604 """__gnat_handler_installed"");");
606 -- The import of the soft link which performs library-level object
607 -- finalization is not needed for VM targets; regular Ada is used in
608 -- that case. For restricted run-time libraries (ZFP and Ravenscar)
609 -- tasks are non-terminating, so we do not want finalization.
611 if VM_Target = No_VM and then not Configurable_Run_Time_On_Target then
613 WBI (" type No_Param_Proc is access procedure;");
614 WBI (" Finalize_Library_Objects : No_Param_Proc;");
615 WBI (" pragma Import (C, Finalize_Library_Objects, " &
616 """__gnat_finalize_library_objects"");");
619 -- Import entry point for environment feature enable/disable
620 -- routine, and indication that it's been called previously.
622 if OpenVMS_On_Target then
624 WBI (" procedure Set_Features;");
625 WBI (" pragma Import (C, Set_Features, " &
626 """__gnat_set_features"");");
628 WBI (" Features_Set : Integer;");
629 WBI (" pragma Import (C, Features_Set, " &
630 """__gnat_features_set"");");
632 if Opt.Heap_Size /= 0 then
634 WBI (" Heap_Size : Integer;");
635 WBI (" pragma Import (C, Heap_Size, " &
636 """__gl_heap_size"");");
638 Write_Statement_Buffer;
642 -- Initialize stack limit variable of the environment task if the
643 -- stack check method is stack limit and stack check is enabled.
645 if Stack_Check_Limits_On_Target
646 and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set)
649 WBI (" procedure Initialize_Stack_Limit;");
650 WBI (" pragma Import (C, Initialize_Stack_Limit, " &
651 """__gnat_initialize_stack_limit"");");
654 -- Special processing when main program is CIL function/procedure
656 if VM_Target = CLI_Target
657 and then Bind_Main_Program
658 and then not No_Main_Subprogram
662 -- Function case, use Set_Exit_Status to report the returned
663 -- status code, since that is the only mechanism available.
665 if ALIs.Table (ALIs.First).Main_Program = Func then
666 WBI (" Result : Integer;");
667 WBI (" procedure Set_Exit_Status (Code : Integer);");
668 WBI (" pragma Import (C, Set_Exit_Status, " &
669 """__gnat_set_exit_status"");");
671 WBI (" function Ada_Main_Program return Integer;");
676 WBI (" procedure Ada_Main_Program;");
679 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
680 Name_Len := Name_Len - 2;
681 WBI (" pragma Import (CIL, Ada_Main_Program, """
682 & Name_Buffer (1 .. Name_Len) & "."
683 & Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len)) & """);");
688 Set_String (" Main_Priority := ");
689 Set_Int (Main_Priority);
691 Write_Statement_Buffer;
693 Set_String (" Time_Slice_Value := ");
695 if Task_Dispatching_Policy_Specified = 'F'
696 and then ALIs.Table (ALIs.First).Time_Slice_Value = -1
700 Set_Int (ALIs.Table (ALIs.First).Time_Slice_Value);
704 Write_Statement_Buffer;
706 Set_String (" WC_Encoding := '");
707 Set_Char (Get_WC_Encoding);
710 Write_Statement_Buffer;
712 Set_String (" Locking_Policy := '");
713 Set_Char (Locking_Policy_Specified);
715 Write_Statement_Buffer;
717 Set_String (" Queuing_Policy := '");
718 Set_Char (Queuing_Policy_Specified);
720 Write_Statement_Buffer;
722 Set_String (" Task_Dispatching_Policy := '");
723 Set_Char (Task_Dispatching_Policy_Specified);
725 Write_Statement_Buffer;
727 Gen_Restrictions_Ada;
729 WBI (" Priority_Specific_Dispatching :=");
730 WBI (" Local_Priority_Specific_Dispatching'Address;");
732 Set_String (" Num_Specific_Dispatching := ");
733 Set_Int (PSD_Pragma_Settings.Last + 1);
735 Write_Statement_Buffer;
737 Set_String (" Main_CPU := ");
740 Write_Statement_Buffer;
742 WBI (" Interrupt_States := Local_Interrupt_States'Address;");
744 Set_String (" Num_Interrupt_States := ");
745 Set_Int (IS_Pragma_Settings.Last + 1);
747 Write_Statement_Buffer;
749 Set_String (" Unreserve_All_Interrupts := ");
751 if Unreserve_All_Interrupts_Specified then
758 Write_Statement_Buffer;
760 if Exception_Tracebacks then
761 WBI (" Exception_Tracebacks := 1;");
764 Set_String (" Zero_Cost_Exceptions := ");
766 if Zero_Cost_Exceptions_Specified then
773 Write_Statement_Buffer;
775 Set_String (" Detect_Blocking := ");
777 if Detect_Blocking then
784 Write_Statement_Buffer;
786 Set_String (" Default_Stack_Size := ");
787 Set_Int (Default_Stack_Size);
789 Write_Statement_Buffer;
791 Set_String (" Leap_Seconds_Support := ");
793 if Leap_Seconds_Support then
800 Write_Statement_Buffer;
802 -- Generate call to Install_Handler
804 -- In .NET, when binding with -z, we don't install the signal handler
805 -- to let the caller handle the last exception handler.
807 if VM_Target /= CLI_Target
808 or else Bind_Main_Program
811 WBI (" if Handler_Installed = 0 then");
812 WBI (" Install_Handler;");
816 -- Generate call to Set_Features
818 if OpenVMS_On_Target then
820 WBI (" if Features_Set = 0 then");
821 WBI (" Set_Features;");
824 -- Features_Set may twiddle the heap size according to a logical
825 -- name, but the binder switch must override.
827 if Opt.Heap_Size /= 0 then
828 Set_String (" Heap_Size := ");
829 Set_Int (Opt.Heap_Size);
831 Write_Statement_Buffer;
836 -- Generate call to set Initialize_Scalar values if active
838 if Initialize_Scalars_Used then
840 Set_String (" System.Scalar_Values.Initialize ('");
841 Set_Char (Initialize_Scalars_Mode1);
843 Set_Char (Initialize_Scalars_Mode2);
845 Write_Statement_Buffer;
848 -- Generate assignment of default secondary stack size if set
850 if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then
852 Set_String (" System.Secondary_Stack.");
853 Set_String ("Default_Secondary_Stack_Size := ");
854 Set_Int (Opt.Default_Sec_Stack_Size);
856 Write_Statement_Buffer;
859 -- Initialize stack limit variable of the environment task if the
860 -- stack check method is stack limit and stack check is enabled.
862 if Stack_Check_Limits_On_Target
863 and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set)
866 WBI (" Initialize_Stack_Limit;");
869 -- In the main program case, attach finalize_library to the soft link.
870 -- Do it only when not using a restricted run time, in which case tasks
871 -- are non-terminating, so we do not want library-level finalization.
874 and then not Configurable_Run_Time_On_Target
875 and then not Suppress_Standard_Library_On_Target
879 if VM_Target = No_VM then
880 if Lib_Final_Built then
881 Set_String (" Finalize_Library_Objects := ");
882 Set_String ("finalize_library'access;");
884 Set_String (" Finalize_Library_Objects := null;");
887 -- On VM targets use regular Ada to set the soft link
890 if Lib_Final_Built then
892 (" System.Soft_Links.Finalize_Library_Objects");
893 Set_String (" := finalize_library'access;");
896 (" System.Soft_Links.Finalize_Library_Objects");
897 Set_String (" := null;");
901 Write_Statement_Buffer;
904 -- Generate elaboration calls
909 -- Case of main program is CIL function or procedure
911 if VM_Target = CLI_Target
912 and then Bind_Main_Program
913 and then not No_Main_Subprogram
915 -- For function case, use Set_Exit_Status to set result
917 if ALIs.Table (ALIs.First).Main_Program = Func then
918 WBI (" Result := Ada_Main_Program;");
919 WBI (" Set_Exit_Status (Result);");
924 WBI (" Ada_Main_Program;");
928 WBI (" end " & Ada_Init_Name.all & ";");
936 procedure Gen_Adainit_C is
937 Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority;
938 Main_CPU : Int renames ALIs.Table (ALIs.First).Main_CPU;
941 WBI ("void " & Ada_Init_Name.all & " (void)");
944 -- Standard library suppressed
946 if Suppress_Standard_Library_On_Target then
948 -- Case of High_Integrity_Mode mode. Set __gl_main_priority and
949 -- __gl_main_cpu if needed for the Ravenscar profile.
951 if Main_Priority /= No_Main_Priority then
952 WBI (" extern int __gl_main_priority;");
953 Set_String (" __gl_main_priority = ");
954 Set_Int (Main_Priority);
956 Write_Statement_Buffer;
959 if Main_CPU /= No_Main_CPU then
960 WBI (" extern int __gl_main_cpu;");
961 Set_String (" __gl_main_cpu = ");
964 Write_Statement_Buffer;
967 -- Normal case (standard library not suppressed)
970 -- Generate definition for interrupt states string
972 Set_String (" static const char *local_interrupt_states = """);
974 for J in 0 .. IS_Pragma_Settings.Last loop
975 Set_Char (IS_Pragma_Settings.Table (J));
979 Write_Statement_Buffer;
981 -- Generate definition for priority specific dispatching string
984 (" static const char *local_priority_specific_dispatching = """);
986 for J in 0 .. PSD_Pragma_Settings.Last loop
987 Set_Char (PSD_Pragma_Settings.Table (J));
991 Write_Statement_Buffer;
993 -- Generate declaration for secondary stack default if needed
995 if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then
996 WBI (" extern int system__secondary_stack__" &
997 "default_secondary_stack_size;");
1002 -- Code for normal case (standard library not suppressed)
1004 -- We call the routine from inside adainit() because this works for
1005 -- both programs with and without binder generated "main" functions.
1007 WBI (" extern int __gl_main_priority;");
1008 Set_String (" __gl_main_priority = ");
1009 Set_Int (Main_Priority);
1011 Write_Statement_Buffer;
1013 WBI (" extern int __gl_time_slice_val;");
1014 Set_String (" __gl_time_slice_val = ");
1016 if Task_Dispatching_Policy = 'F'
1017 and then ALIs.Table (ALIs.First).Time_Slice_Value = -1
1021 Set_Int (ALIs.Table (ALIs.First).Time_Slice_Value);
1025 Write_Statement_Buffer;
1027 WBI (" extern char __gl_wc_encoding;");
1028 Set_String (" __gl_wc_encoding = '");
1029 Set_Char (Get_WC_Encoding);
1032 Write_Statement_Buffer;
1034 WBI (" extern char __gl_locking_policy;");
1035 Set_String (" __gl_locking_policy = '");
1036 Set_Char (Locking_Policy_Specified);
1038 Write_Statement_Buffer;
1040 WBI (" extern char __gl_queuing_policy;");
1041 Set_String (" __gl_queuing_policy = '");
1042 Set_Char (Queuing_Policy_Specified);
1044 Write_Statement_Buffer;
1046 WBI (" extern char __gl_task_dispatching_policy;");
1047 Set_String (" __gl_task_dispatching_policy = '");
1048 Set_Char (Task_Dispatching_Policy_Specified);
1050 Write_Statement_Buffer;
1052 WBI (" extern int __gl_main_cpu;");
1053 Set_String (" __gl_main_cpu = ");
1056 Write_Statement_Buffer;
1060 WBI (" extern const void *__gl_interrupt_states;");
1061 WBI (" __gl_interrupt_states = local_interrupt_states;");
1063 WBI (" extern int __gl_num_interrupt_states;");
1064 Set_String (" __gl_num_interrupt_states = ");
1065 Set_Int (IS_Pragma_Settings.Last + 1);
1067 Write_Statement_Buffer;
1069 WBI (" extern const void *__gl_priority_specific_dispatching;");
1070 WBI (" __gl_priority_specific_dispatching =" &
1071 " local_priority_specific_dispatching;");
1073 WBI (" extern int __gl_num_specific_dispatching;");
1074 Set_String (" __gl_num_specific_dispatching = ");
1075 Set_Int (PSD_Pragma_Settings.Last + 1);
1077 Write_Statement_Buffer;
1079 WBI (" extern int __gl_unreserve_all_interrupts;");
1080 Set_String (" __gl_unreserve_all_interrupts = ");
1081 Set_Int (Boolean'Pos (Unreserve_All_Interrupts_Specified));
1083 Write_Statement_Buffer;
1085 if Exception_Tracebacks then
1086 WBI (" extern int __gl_exception_tracebacks;");
1087 WBI (" __gl_exception_tracebacks = 1;");
1090 WBI (" extern int __gl_zero_cost_exceptions;");
1091 Set_String (" __gl_zero_cost_exceptions = ");
1092 Set_Int (Boolean'Pos (Zero_Cost_Exceptions_Specified));
1094 Write_Statement_Buffer;
1096 WBI (" extern int __gl_detect_blocking;");
1097 Set_String (" __gl_detect_blocking = ");
1099 if Detect_Blocking then
1106 Write_Statement_Buffer;
1108 WBI (" extern int __gl_default_stack_size;");
1109 Set_String (" __gl_default_stack_size = ");
1110 Set_Int (Default_Stack_Size);
1112 Write_Statement_Buffer;
1114 WBI (" extern int __gl_leap_seconds_support;");
1115 Set_String (" __gl_leap_seconds_support = ");
1117 if Leap_Seconds_Support then
1124 Write_Statement_Buffer;
1126 -- Import entry point for elaboration time signal handler
1127 -- installation, and indication of if it's been called previously.
1129 WBI (" extern int __gnat_handler_installed;");
1132 -- Install elaboration time signal handler
1134 WBI (" if (__gnat_handler_installed == 0)");
1135 WBI (" __gnat_install_handler ();");
1137 -- Import entry point for environment feature enable/disable
1138 -- routine, and indication that it's been called previously.
1140 if OpenVMS_On_Target then
1141 WBI (" extern int __gnat_features_set;");
1144 WBI (" if (__gnat_features_set == 0)");
1145 WBI (" __gnat_set_features ();");
1149 -- Initialize stack limit for the environment task if the stack
1150 -- check method is stack limit and stack check is enabled.
1152 if Stack_Check_Limits_On_Target
1153 and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set)
1156 WBI (" __gnat_initialize_stack_limit ();");
1159 -- Generate call to set Initialize_Scalar values if needed
1161 if Initialize_Scalars_Used then
1163 Set_String (" system__scalar_values__initialize('");
1164 Set_Char (Initialize_Scalars_Mode1);
1165 Set_String ("', '");
1166 Set_Char (Initialize_Scalars_Mode2);
1168 Write_Statement_Buffer;
1171 -- Generate assignment of default secondary stack size if set
1173 if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then
1175 Set_String (" system__secondary_stack__");
1176 Set_String ("default_secondary_stack_size = ");
1177 Set_Int (Opt.Default_Sec_Stack_Size);
1179 Write_Statement_Buffer;
1182 -- In the main program case, attach finalize_library to the soft link.
1183 -- Do it only when not using a restricted run time, in which case tasks
1184 -- are non-terminating, so we do not want library-level finalization.
1186 if Bind_Main_Program
1187 and then not Configurable_Run_Time_On_Target
1188 and then not Suppress_Standard_Library_On_Target
1191 WBI (" extern void (*__gnat_finalize_library_objects)(void);");
1193 if Lib_Final_Built then
1194 Set_String (" __gnat_finalize_library_objects = ");
1195 Set_String ("&finalize_library;");
1197 Set_String (" __gnat_finalize_library_objects = 0;");
1200 Write_Statement_Buffer;
1203 -- Generate elaboration calls
1211 ----------------------------
1212 -- Gen_Elab_Externals_Ada --
1213 ----------------------------
1215 procedure Gen_Elab_Externals_Ada is
1217 for E in Elab_Order.First .. Elab_Order.Last loop
1219 Unum : constant Unit_Id := Elab_Order.Table (E);
1220 U : Unit_Record renames Units.Table (Unum);
1223 -- Check for Elab_Entity to be set for this unit
1225 if U.Set_Elab_Entity
1227 -- Don't generate reference for stand alone library
1229 and then not U.SAL_Interface
1231 -- Don't generate reference for predefined file in No_Run_Time
1232 -- mode, since we don't include the object files in this case
1236 and then Is_Predefined_File_Name (U.Sfile))
1240 Set_Unit_Number (Unum);
1243 when No_VM | JVM_Target =>
1244 Set_String (" : Integer; pragma Import (Ada, ");
1246 Set_String (" : Integer; pragma Import (CIL, ");
1250 Set_Unit_Number (Unum);
1251 Set_String (", """);
1252 Get_Name_String (U.Uname);
1254 -- In the case of JGNAT we need to emit an Import name that
1255 -- includes the class name (using '$' separators in the case
1256 -- of a child unit name).
1258 if VM_Target /= No_VM then
1259 for J in 1 .. Name_Len - 2 loop
1260 if VM_Target = CLI_Target
1261 or else Name_Buffer (J) /= '.'
1263 Set_Char (Name_Buffer (J));
1269 if VM_Target /= CLI_Target or else U.Unit_Kind = 's' then
1272 Set_String ("_pkg.");
1275 -- If the unit name is very long, then split the
1276 -- Import link name across lines using "&" (occurs
1277 -- in some C2 tests).
1279 if 2 * Name_Len + 60 > Hostparm.Max_Line_Length then
1280 Set_String (""" &");
1281 Write_Statement_Buffer;
1287 Set_String ("_E"");");
1288 Write_Statement_Buffer;
1294 end Gen_Elab_Externals_Ada;
1296 --------------------------
1297 -- Gen_Elab_Externals_C --
1298 --------------------------
1300 procedure Gen_Elab_Externals_C is
1302 for E in Elab_Order.First .. Elab_Order.Last loop
1304 Unum : constant Unit_Id := Elab_Order.Table (E);
1305 U : Unit_Record renames Units.Table (Unum);
1308 -- Check for Elab entity to be set for this unit
1310 if U.Set_Elab_Entity
1312 -- Don't generate reference for stand alone library
1314 and then not U.SAL_Interface
1316 -- Don't generate reference for predefined file in No_Run_Time
1317 -- mode, since we don't include the object files in this case
1321 and then Is_Predefined_File_Name (U.Sfile))
1323 Set_String ("extern int ");
1324 Get_Name_String (U.Uname);
1327 Write_Statement_Buffer;
1333 end Gen_Elab_Externals_C;
1335 ------------------------
1336 -- Gen_Elab_Calls_Ada --
1337 ------------------------
1339 procedure Gen_Elab_Calls_Ada is
1341 for E in Elab_Order.First .. Elab_Order.Last loop
1343 Unum : constant Unit_Id := Elab_Order.Table (E);
1344 U : Unit_Record renames Units.Table (Unum);
1346 Unum_Spec : Unit_Id;
1347 -- This is the unit number of the spec that corresponds to
1348 -- this entry. It is the same as Unum except when the body
1349 -- and spec are different and we are currently processing
1350 -- the body, in which case it is the spec (Unum + 1).
1353 if U.Utype = Is_Body then
1354 Unum_Spec := Unum + 1;
1359 -- Nothing to do if predefined unit in no run time mode
1361 if No_Run_Time_Mode and then Is_Predefined_File_Name (U.Sfile) then
1364 -- Likewise if this is an interface to a stand alone library
1366 elsif U.SAL_Interface then
1369 -- Case of no elaboration code
1371 elsif U.No_Elab then
1373 -- The only case in which we have to do something is if this
1374 -- is a body, with a separate spec, where the separate spec
1375 -- has an elaboration entity defined. In that case, this is
1376 -- where we increment the elaboration entity.
1378 if U.Utype = Is_Body
1379 and then Units.Table (Unum_Spec).Set_Elab_Entity
1382 Set_Unit_Number (Unum_Spec);
1383 Set_String (" := E");
1384 Set_Unit_Number (Unum_Spec);
1385 Set_String (" + 1;");
1386 Write_Statement_Buffer;
1389 -- Here if elaboration code is present. If binding a library
1390 -- or if there is a non-Ada main subprogram then we generate:
1392 -- if uname_E = 0 then
1393 -- uname'elab_[spec|body];
1395 -- uname_E := uname_E + 1;
1397 -- Otherwise, elaboration routines are called unconditionally:
1399 -- uname'elab_[spec|body];
1400 -- uname_E := uname_E + 1;
1402 -- The uname_E increment is skipped if this is a separate spec,
1403 -- since it will be done when we process the body.
1406 if Force_Checking_Of_Elaboration_Flags or
1407 Interface_Library_Unit or
1408 (not Bind_Main_Program)
1410 Set_String (" if E");
1411 Set_Unit_Number (Unum_Spec);
1412 Set_String (" = 0 then");
1413 Write_Statement_Buffer;
1418 Get_Decoded_Name_String_With_Brackets (U.Uname);
1420 if VM_Target = CLI_Target and then U.Unit_Kind /= 's' then
1421 if Name_Buffer (Name_Len) = 's' then
1422 Name_Buffer (Name_Len - 1 .. Name_Len + 12) :=
1425 Name_Buffer (Name_Len - 1 .. Name_Len + 12) :=
1429 Name_Len := Name_Len + 12;
1432 if Name_Buffer (Name_Len) = 's' then
1433 Name_Buffer (Name_Len - 1 .. Name_Len + 8) :=
1436 Name_Buffer (Name_Len - 1 .. Name_Len + 8) :=
1440 Name_Len := Name_Len + 8;
1443 Set_Casing (U.Icasing);
1446 Write_Statement_Buffer;
1448 if Force_Checking_Of_Elaboration_Flags or
1449 Interface_Library_Unit or
1450 (not Bind_Main_Program)
1455 if U.Utype /= Is_Spec then
1457 Set_Unit_Number (Unum_Spec);
1458 Set_String (" := E");
1459 Set_Unit_Number (Unum_Spec);
1460 Set_String (" + 1;");
1461 Write_Statement_Buffer;
1466 end Gen_Elab_Calls_Ada;
1468 ----------------------
1469 -- Gen_Elab_Calls_C --
1470 ----------------------
1472 procedure Gen_Elab_Calls_C is
1474 for E in Elab_Order.First .. Elab_Order.Last loop
1476 Unum : constant Unit_Id := Elab_Order.Table (E);
1477 U : Unit_Record renames Units.Table (Unum);
1479 Unum_Spec : Unit_Id;
1480 -- This is the unit number of the spec that corresponds to
1481 -- this entry. It is the same as Unum except when the body
1482 -- and spec are different and we are currently processing
1483 -- the body, in which case it is the spec (Unum + 1).
1486 if U.Utype = Is_Body then
1487 Unum_Spec := Unum + 1;
1492 -- Nothing to do if predefined unit in no run time mode
1494 if No_Run_Time_Mode and then Is_Predefined_File_Name (U.Sfile) then
1497 -- Likewise if this is an interface to a stand alone library
1499 elsif U.SAL_Interface then
1502 -- Case of no elaboration code
1504 elsif U.No_Elab then
1506 -- The only case in which we have to do something is if this
1507 -- is a body, with a separate spec, where the separate spec
1508 -- has an elaboration entity defined. In that case, this is
1509 -- where we increment the elaboration entity.
1511 if U.Utype = Is_Body
1512 and then Units.Table (Unum_Spec).Set_Elab_Entity
1514 Get_Name_String (U.Uname);
1518 Set_String ("_E++;");
1519 Write_Statement_Buffer;
1522 -- Here if elaboration code is present. If binding a library
1523 -- or if there is a non-Ada main subprogram then we generate:
1525 -- if (uname_E == 0)
1526 -- uname__elab[s|b] ();
1529 -- Otherwise, elaboration routines are called unconditionally:
1531 -- uname__elab[s|b] ();
1534 -- The uname_E increment is skipped if this is a separate spec,
1535 -- since it will be done when we process the body.
1538 Get_Name_String (U.Uname);
1540 if Force_Checking_Of_Elaboration_Flags or
1541 Interface_Library_Unit or
1542 (not Bind_Main_Program)
1544 Set_String (" if (");
1546 Set_String ("_E == 0)");
1547 Write_Statement_Buffer;
1553 Set_String ("___elab");
1554 Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body
1555 Set_String (" ();");
1556 Write_Statement_Buffer;
1558 if U.Utype /= Is_Spec then
1561 Set_String ("_E++;");
1562 Write_Statement_Buffer;
1567 end Gen_Elab_Calls_C;
1569 ----------------------
1570 -- Gen_Elab_Defs_C --
1571 ----------------------
1573 procedure Gen_Elab_Defs_C is
1575 WBI ("/* BEGIN ELABORATION DEFINITIONS */");
1577 for E in Elab_Order.First .. Elab_Order.Last loop
1579 -- Generate declaration of elaboration procedure if elaboration
1580 -- needed. Note that passive units are always excluded.
1582 if not Units.Table (Elab_Order.Table (E)).No_Elab then
1583 Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
1584 Set_String ("extern void ");
1586 Set_String ("___elab");
1587 Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body
1588 Set_String (" (void);");
1589 Write_Statement_Buffer;
1593 WBI ("/* END ELABORATION DEFINITIONS */");
1595 end Gen_Elab_Defs_C;
1597 ------------------------
1598 -- Gen_Elab_Order_Ada --
1599 ------------------------
1601 procedure Gen_Elab_Order_Ada is
1603 WBI (" -- BEGIN ELABORATION ORDER");
1605 for J in Elab_Order.First .. Elab_Order.Last loop
1606 Set_String (" -- ");
1607 Get_Name_String (Units.Table (Elab_Order.Table (J)).Uname);
1609 Write_Statement_Buffer;
1612 WBI (" -- END ELABORATION ORDER");
1614 end Gen_Elab_Order_Ada;
1616 ----------------------
1617 -- Gen_Elab_Order_C --
1618 ----------------------
1620 procedure Gen_Elab_Order_C is
1622 WBI ("/* BEGIN ELABORATION ORDER");
1624 for J in Elab_Order.First .. Elab_Order.Last loop
1625 Get_Name_String (Units.Table (Elab_Order.Table (J)).Uname);
1627 Write_Statement_Buffer;
1630 WBI (" END ELABORATION ORDER */");
1632 end Gen_Elab_Order_C;
1634 ------------------------------
1635 -- Gen_Finalize_Library_Ada --
1636 ------------------------------
1638 procedure Gen_Finalize_Library_Ada is
1641 Uspec : Unit_Record;
1645 for E in reverse Elab_Order.First .. Elab_Order.Last loop
1646 Unum := Elab_Order.Table (E);
1647 U := Units.Table (Unum);
1649 -- We are only interested in non-generic packages
1651 if U.Unit_Kind = 'p'
1652 and then U.Has_Finalizer
1653 and then not U.Is_Generic
1654 and then not U.SAL_Interface
1655 and then not U.No_Elab
1657 if not Lib_Final_Built then
1658 Lib_Final_Built := True;
1660 WBI (" procedure finalize_library is");
1662 -- The following flag is used to check for library-level
1663 -- exceptions raised during finalization. The symbol comes
1664 -- from System.Soft_Links. VM targets use regular Ada to
1665 -- reference the entity.
1667 if VM_Target = No_VM then
1668 WBI (" LE_Set : Boolean;");
1670 Set_String (" pragma Import (Ada, LE_Set, ");
1671 Set_String ("""__gnat_library_exception_set"");");
1672 Write_Statement_Buffer;
1680 -- procedure F<Count>;
1682 Set_String (" declare");
1683 Write_Statement_Buffer;
1685 Set_String (" procedure F");
1688 Write_Statement_Buffer;
1691 -- pragma Import (CIL, F<Count>, "xx.yy_pkg.Finalize[B/S]");
1692 -- -- for .NET targets
1694 -- pragma Import (Java, F<Count>, "xx$yy.Finalize[B/S]");
1695 -- -- for JVM targets
1697 -- pragma Import (Ada, F<Count>, "xx__yy__Finalize[B/S]");
1698 -- -- for default targets
1700 if VM_Target = CLI_Target then
1701 Set_String (" pragma Import (CIL, F");
1702 elsif VM_Target = JVM_Target then
1703 Set_String (" pragma Import (Java, F");
1705 Set_String (" pragma Import (Ada, F");
1709 Set_String (", """);
1711 -- Dealing with package bodies is a little complicated. In such
1712 -- cases we must retrieve the package spec since it contains the
1713 -- spec of the body finalizer.
1715 if U.Utype = Is_Body then
1717 Uspec := Units.Table (Unum);
1722 Get_Name_String (Uspec.Uname);
1724 -- Perform name construction
1726 -- .NET xx.yy_pkg.finalize
1728 if VM_Target = CLI_Target then
1729 Set_Unit_Name (Mode => Dot);
1730 Set_String ("_pkg.finalize");
1732 -- JVM xx$yy.finalize
1734 elsif VM_Target = JVM_Target then
1735 Set_Unit_Name (Mode => Dollar_Sign);
1736 Set_String (".finalize");
1738 -- Default xx__yy__finalize
1742 Set_String ("__finalize");
1745 -- Package spec processing
1747 if U.Utype = Is_Spec
1748 or else U.Utype = Is_Spec_Only
1752 -- Package body processing
1758 Set_String (""");");
1759 Write_Statement_Buffer;
1761 -- If binding a library or if there is a non-Ada main subprogram
1762 -- then we generate:
1765 -- uname_E := uname_E - 1;
1766 -- if uname_E = 0 then
1771 -- Otherwise, finalization routines are called unconditionally:
1774 -- uname_E := uname_E - 1;
1780 Set_Unit_Number (Unum);
1781 Set_String (" := E");
1782 Set_Unit_Number (Unum);
1783 Set_String (" - 1;");
1784 Write_Statement_Buffer;
1786 if Interface_Library_Unit or (not Bind_Main_Program) then
1787 Set_String (" if E");
1788 Set_Unit_Number (Unum);
1789 Set_String (" = 0 then");
1790 Write_Statement_Buffer;
1797 Write_Statement_Buffer;
1799 if Interface_Library_Unit or (not Bind_Main_Program) then
1809 if Lib_Final_Built then
1811 -- It is possible that the finalization of a library-level object
1812 -- raised an exception. In that case import the actual exception
1813 -- and the routine necessary to raise it.
1815 if VM_Target = No_VM then
1816 WBI (" if LE_Set then");
1818 WBI (" LE : Ada.Exceptions.Exception_Occurrence;");
1820 Set_String (" pragma Import (Ada, LE, ");
1821 Set_String ("""__gnat_library_exception"");");
1822 Write_Statement_Buffer;
1824 Set_String (" procedure Raise_Controlled ");
1825 Set_String ("(E : Ada.Exceptions.Exception_Occurrence);");
1826 Write_Statement_Buffer;
1828 Set_String (" pragma Import (Ada, Raise_Controlled, ");
1829 Set_String ("""__gnat_raise_from_controlled_operation"");");
1830 Write_Statement_Buffer;
1833 WBI (" Raise_Controlled (LE);");
1836 -- VM-specific code, use regular Ada to produce the desired behavior
1839 WBI (" if System.Soft_Links.Library_Exception_Set then");
1841 Set_String (" Ada.Exceptions.Reraise_Occurrence (");
1842 Set_String ("System.Soft_Links.Library_Exception);");
1843 Write_Statement_Buffer;
1847 WBI (" end finalize_library;");
1850 end Gen_Finalize_Library_Ada;
1852 ----------------------------
1853 -- Gen_Finalize_Library_C --
1854 ----------------------------
1856 procedure Gen_Finalize_Library_C is
1858 Uspec : Unit_Record;
1862 for E in reverse Elab_Order.First .. Elab_Order.Last loop
1863 Unum := Elab_Order.Table (E);
1864 U := Units.Table (Unum);
1866 -- We are only interested in non-generic packages
1868 if U.Unit_Kind = 'p'
1869 and then U.Has_Finalizer
1870 and then not U.Is_Generic
1871 and then not U.SAL_Interface
1872 and then not U.No_Elab
1874 if not Lib_Final_Built then
1875 Lib_Final_Built := True;
1877 WBI ("static void finalize_library(void) {");
1880 -- Dealing with package bodies is a little complicated. In such
1881 -- cases we must retrieve the package spec since it contains the
1882 -- spec of the body finalizer.
1884 if U.Utype = Is_Body then
1886 Uspec := Units.Table (Unum);
1891 Get_Name_String (Uspec.Uname);
1893 -- If binding a library or if there is a non-Ada main subprogram
1894 -- then we generate:
1897 -- if (uname_E == 0)
1898 -- uname__finalize[S|B] ();
1900 -- Otherwise, finalization routines are called unconditionally:
1903 -- uname__finalize[S|B] ();
1907 Set_String ("_E--;");
1908 Write_Statement_Buffer;
1910 if Interface_Library_Unit or (not Bind_Main_Program) then
1911 Set_String (" if (");
1913 Set_String ("_E == 0)");
1914 Write_Statement_Buffer;
1919 Get_Name_String (Uspec.Uname);
1921 Set_String ("__finalize");
1923 -- Package spec processing
1925 if U.Utype = Is_Spec
1926 or else U.Utype = Is_Spec_Only
1930 -- Package body processing
1936 Set_String (" ();");
1938 Write_Statement_Buffer;
1942 if Lib_Final_Built then
1946 end Gen_Finalize_Library_C;
1948 ---------------------------------
1949 -- Gen_Finalize_Library_Defs_C --
1950 ---------------------------------
1952 procedure Gen_Finalize_Library_Defs_C is
1954 Uspec : Unit_Record;
1958 WBI ("/* BEGIN FINALIZE DEFINITIONS */");
1960 for E in reverse Elab_Order.First .. Elab_Order.Last loop
1961 Unum := Elab_Order.Table (E);
1962 U := Units.Table (Unum);
1964 -- We are only interested in non-generic packages
1966 if U.Unit_Kind = 'p'
1967 and then U.Has_Finalizer
1968 and then not U.Is_Generic
1969 and then not U.No_Elab
1971 -- Dealing with package bodies is a little complicated. In such
1972 -- cases we must retrieve the package spec since it contains the
1973 -- spec of the body finalizer.
1975 if U.Utype = Is_Body then
1977 Uspec := Units.Table (Unum);
1982 Set_String ("extern void ");
1983 Get_Name_String (Uspec.Uname);
1985 Set_String ("__finalize");
1987 if U.Utype = Is_Spec
1988 or else U.Utype = Is_Spec_Only
1995 Set_String (" (void);");
1996 Write_Statement_Buffer;
2000 WBI ("/* END FINALIZE DEFINITIONS */");
2002 end Gen_Finalize_Library_Defs_C;
2008 procedure Gen_Main_Ada is
2010 if Exit_Status_Supported_On_Target then
2011 Set_String (" function ");
2013 Set_String (" procedure ");
2016 Set_String (Get_Main_Name);
2018 if Command_Line_Args_On_Target then
2019 Write_Statement_Buffer;
2020 WBI (" (argc : Integer;");
2021 WBI (" argv : System.Address;");
2022 WBI (" envp : System.Address)");
2024 if Exit_Status_Supported_On_Target then
2025 WBI (" return Integer");
2031 if Exit_Status_Supported_On_Target then
2032 Set_String (" return Integer is");
2037 Write_Statement_Buffer;
2040 if Opt.Default_Exit_Status /= 0
2041 and then Bind_Main_Program
2042 and then not Configurable_Run_Time_Mode
2044 WBI (" procedure Set_Exit_Status (Status : Integer);");
2045 WBI (" pragma Import (C, Set_Exit_Status, " &
2046 """__gnat_set_exit_status"");");
2050 -- Initialize and Finalize
2052 if not Cumulative_Restrictions.Set (No_Finalization) then
2053 WBI (" procedure Initialize (Addr : System.Address);");
2054 WBI (" pragma Import (C, Initialize, ""__gnat_initialize"");");
2056 WBI (" procedure Finalize;");
2057 WBI (" pragma Import (C, Finalize, ""__gnat_finalize"");");
2060 -- If we want to analyze the stack, we have to import corresponding
2063 if Dynamic_Stack_Measurement then
2065 WBI (" procedure Output_Results;");
2066 WBI (" pragma Import (C, Output_Results, " &
2067 """__gnat_stack_usage_output_results"");");
2071 "procedure Initialize_Stack_Analysis (Buffer_Size : Natural);");
2072 WBI (" pragma Import (C, Initialize_Stack_Analysis, " &
2073 """__gnat_stack_usage_initialize"");");
2076 -- Deal with declarations for main program case
2078 if not No_Main_Subprogram then
2080 -- To call the main program, we declare it using a pragma Import
2081 -- Ada with the right link name.
2083 -- It might seem more obvious to "with" the main program, and call
2084 -- it in the normal Ada manner. We do not do this for three reasons:
2086 -- 1. It is more efficient not to recompile the main program
2087 -- 2. We are not entitled to assume the source is accessible
2088 -- 3. We don't know what options to use to compile it
2090 -- It is really reason 3 that is most critical (indeed we used
2091 -- to generate the "with", but several regression tests failed).
2095 if ALIs.Table (ALIs.First).Main_Program = Func then
2096 WBI (" Result : Integer;");
2098 WBI (" function Ada_Main_Program return Integer;");
2101 WBI (" procedure Ada_Main_Program;");
2104 Set_String (" pragma Import (Ada, Ada_Main_Program, """);
2105 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
2106 Set_Main_Program_Name;
2107 Set_String (""");");
2109 Write_Statement_Buffer;
2112 if Bind_Main_Program
2113 and then not Suppress_Standard_Library_On_Target
2115 WBI (" SEH : aliased array (1 .. 2) of Integer;");
2120 -- Generate a reference to Ada_Main_Program_Name. This symbol is
2121 -- not referenced elsewhere in the generated program, but is needed
2122 -- by the debugger (that's why it is generated in the first place).
2123 -- The reference stops Ada_Main_Program_Name from being optimized
2124 -- away by smart linkers, such as the AiX linker.
2126 -- Because this variable is unused, we make this variable "aliased"
2127 -- with a pragma Volatile in order to tell the compiler to preserve
2128 -- this variable at any level of optimization.
2130 if Bind_Main_Program then
2132 (" Ensure_Reference : aliased System.Address := " &
2133 "Ada_Main_Program_Name'Address;");
2134 WBI (" pragma Volatile (Ensure_Reference);");
2140 -- Acquire command line arguments if present on target
2142 if Command_Line_Args_On_Target then
2143 WBI (" gnat_argc := argc;");
2144 WBI (" gnat_argv := argv;");
2145 WBI (" gnat_envp := envp;");
2148 -- If configurable run time and no command line args, then nothing
2149 -- needs to be done since the gnat_argc/argv/envp variables are
2150 -- suppressed in this case.
2152 elsif Configurable_Run_Time_On_Target then
2155 -- Otherwise set dummy values (to be filled in by some other unit?)
2158 WBI (" gnat_argc := 0;");
2159 WBI (" gnat_argv := System.Null_Address;");
2160 WBI (" gnat_envp := System.Null_Address;");
2163 if Opt.Default_Exit_Status /= 0
2164 and then Bind_Main_Program
2165 and then not Configurable_Run_Time_Mode
2167 Set_String (" Set_Exit_Status (");
2168 Set_Int (Opt.Default_Exit_Status);
2170 Write_Statement_Buffer;
2173 if Dynamic_Stack_Measurement then
2174 Set_String (" Initialize_Stack_Analysis (");
2175 Set_Int (Dynamic_Stack_Measurement_Array_Size);
2177 Write_Statement_Buffer;
2180 if not Cumulative_Restrictions.Set (No_Finalization) then
2181 if not No_Main_Subprogram
2182 and then Bind_Main_Program
2183 and then not Suppress_Standard_Library_On_Target
2185 WBI (" Initialize (SEH'Address);");
2187 WBI (" Initialize (System.Null_Address);");
2191 WBI (" " & Ada_Init_Name.all & ";");
2193 if not No_Main_Subprogram then
2194 WBI (" Break_Start;");
2196 if ALIs.Table (ALIs.First).Main_Program = Proc then
2197 WBI (" Ada_Main_Program;");
2199 WBI (" Result := Ada_Main_Program;");
2203 -- Adafinal call is skipped if no finalization
2205 if not Cumulative_Restrictions.Set (No_Finalization) then
2209 -- Prints the result of static stack analysis
2211 if Dynamic_Stack_Measurement then
2212 WBI (" Output_Results;");
2215 -- Finalize is only called if we have a run time
2217 if not Cumulative_Restrictions.Set (No_Finalization) then
2223 if Exit_Status_Supported_On_Target then
2224 if No_Main_Subprogram
2225 or else ALIs.Table (ALIs.First).Main_Program = Proc
2227 WBI (" return (gnat_exit_status);");
2229 WBI (" return (Result);");
2241 procedure Gen_Main_C is
2243 if Exit_Status_Supported_On_Target then
2244 WBI ("#include <stdlib.h>");
2246 Set_String ("int ");
2248 Set_String ("void ");
2251 Set_String (Get_Main_Name);
2253 -- Generate command line args in prototype if present on target
2255 if Command_Line_Args_On_Target then
2256 Write_Statement_Buffer (" (int argc, char **argv, char **envp)");
2258 -- Case of no command line arguments on target
2261 Write_Statement_Buffer (" (void)");
2266 -- Generate a reference to __gnat_ada_main_program_name. This symbol
2267 -- is not referenced elsewhere in the generated program, but is
2268 -- needed by the debugger (that's why it is generated in the first
2269 -- place). The reference stops Ada_Main_Program_Name from being
2270 -- optimized away by smart linkers, such as the AiX linker.
2272 -- Because this variable is unused, we declare this variable as
2273 -- volatile in order to tell the compiler to preserve it at any
2274 -- level of optimization.
2276 if Bind_Main_Program then
2277 WBI (" char * volatile ensure_reference " &
2278 "__attribute__ ((__unused__)) = " &
2279 "__gnat_ada_main_program_name;");
2282 if not Suppress_Standard_Library_On_Target
2283 and then not No_Main_Subprogram
2285 WBI (" int SEH [2];");
2290 -- If main program is a function, generate result variable
2292 if ALIs.Table (ALIs.First).Main_Program = Func then
2293 WBI (" int result;");
2296 -- Set command line argument values from parameters if command line
2297 -- arguments are present on target
2299 if Command_Line_Args_On_Target then
2300 WBI (" gnat_argc = argc;");
2301 WBI (" gnat_argv = argv;");
2302 WBI (" gnat_envp = envp;");
2305 -- If configurable run-time, then nothing to do, since in this case
2306 -- the gnat_argc/argv/envp variables are entirely suppressed.
2308 elsif Configurable_Run_Time_On_Target then
2311 -- if no command line arguments on target, set dummy values
2314 WBI (" gnat_argc = 0;");
2315 WBI (" gnat_argv = 0;");
2316 WBI (" gnat_envp = 0;");
2319 if Opt.Default_Exit_Status /= 0
2320 and then Bind_Main_Program
2321 and then not Configurable_Run_Time_Mode
2323 Set_String (" __gnat_set_exit_status (");
2324 Set_Int (Opt.Default_Exit_Status);
2326 Write_Statement_Buffer;
2329 -- Initializes dynamic stack measurement if needed
2331 if Dynamic_Stack_Measurement then
2332 Set_String (" __gnat_stack_usage_initialize (");
2333 Set_Int (Dynamic_Stack_Measurement_Array_Size);
2335 Write_Statement_Buffer;
2338 -- The __gnat_initialize routine is used only if we have a run-time
2340 if not Suppress_Standard_Library_On_Target then
2341 if not No_Main_Subprogram and then Bind_Main_Program then
2342 WBI (" __gnat_initialize ((void *)SEH);");
2344 WBI (" __gnat_initialize ((void *)0);");
2348 WBI (" " & Ada_Init_Name.all & " ();");
2350 if not No_Main_Subprogram then
2351 WBI (" __gnat_break_start ();");
2353 -- Output main program name
2355 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
2357 -- Main program is procedure case
2359 if ALIs.Table (ALIs.First).Main_Program = Proc then
2361 Set_Main_Program_Name;
2362 Set_String (" ();");
2363 Write_Statement_Buffer;
2365 -- Main program is function case
2367 else -- ALIs.Table (ALIs_First).Main_Program = Func
2368 Set_String (" result = ");
2369 Set_Main_Program_Name;
2370 Set_String (" ();");
2371 Write_Statement_Buffer;
2376 -- Call adafinal if finalization active
2378 if not Cumulative_Restrictions.Set (No_Finalization) then
2379 WBI (" " & Ada_Final_Name.all & " ();");
2382 -- Outputs the dynamic stack measurement if needed
2384 if Dynamic_Stack_Measurement then
2385 WBI (" __gnat_stack_usage_output_results ();");
2388 -- The finalize routine is used only if we have a run-time
2390 if not Suppress_Standard_Library_On_Target then
2391 WBI (" __gnat_finalize ();");
2394 -- Case of main program is a function, so the value it returns
2395 -- is the exit status in this case.
2397 if ALIs.Table (ALIs.First).Main_Program = Func then
2398 if Exit_Status_Supported_On_Target then
2400 -- VMS must use Posix exit routine in order to get the effect
2401 -- of a Unix compatible setting of the program exit status.
2402 -- For all other systems, we use the standard exit routine.
2404 if OpenVMS_On_Target then
2405 WBI (" decc$__posix_exit (result);");
2407 WBI (" exit (result);");
2411 -- Case of main program is a procedure, in which case the exit
2412 -- status is whatever was set by a Set_Exit call most recently
2415 if Exit_Status_Supported_On_Target then
2417 -- VMS must use Posix exit routine in order to get the effect
2418 -- of a Unix compatible setting of the program exit status.
2419 -- For all other systems, we use the standard exit routine.
2421 if OpenVMS_On_Target then
2422 WBI (" decc$__posix_exit (gnat_exit_status);");
2424 WBI (" exit (gnat_exit_status);");
2433 ------------------------------
2434 -- Gen_Object_Files_Options --
2435 ------------------------------
2437 procedure Gen_Object_Files_Options is
2439 -- This keeps track of the position in the sorted set of entries
2440 -- in the Linker_Options table of where the first entry from an
2441 -- internal file appears.
2443 Linker_Option_List_Started : Boolean := False;
2444 -- Set to True when "LINKER OPTION LIST" is displayed
2446 procedure Write_Linker_Option;
2447 -- Write binder info linker option
2449 -------------------------
2450 -- Write_Linker_Option --
2451 -------------------------
2453 procedure Write_Linker_Option is
2458 -- Loop through string, breaking at null's
2461 while Start < Name_Len loop
2463 -- Find null ending this section
2466 while Name_Buffer (Stop) /= ASCII.NUL
2467 and then Stop <= Name_Len loop
2471 -- Process section if non-null
2473 if Stop > Start then
2474 if Output_Linker_Option_List then
2475 if not Zero_Formatting then
2476 if not Linker_Option_List_Started then
2477 Linker_Option_List_Started := True;
2479 Write_Str (" LINKER OPTION LIST");
2487 Write_Str (Name_Buffer (Start .. Stop - 1));
2491 (" -- ", "", Name_Buffer (Start .. Stop - 1));
2496 end Write_Linker_Option;
2498 -- Start of processing for Gen_Object_Files_Options
2501 Write_Info_Ada_C ("-- ", "/* ", " BEGIN Object file/option list");
2503 if Object_List_Filename /= null then
2504 Set_List_File (Object_List_Filename.all);
2507 for E in Elab_Order.First .. Elab_Order.Last loop
2509 -- If not spec that has an associated body, then generate a comment
2510 -- giving the name of the corresponding object file.
2512 if (not Units.Table (Elab_Order.Table (E)).SAL_Interface)
2513 and then Units.Table (Elab_Order.Table (E)).Utype /= Is_Spec
2517 (Units.Table (Elab_Order.Table (E)).My_ALI).Ofile_Full_Name);
2519 -- If the presence of an object file is necessary or if it exists,
2522 if not Hostparm.Exclude_Missing_Objects
2524 System.OS_Lib.Is_Regular_File (Name_Buffer (1 .. Name_Len))
2526 Write_Info_Ada_C (" -- ", "", Name_Buffer (1 .. Name_Len));
2528 if Output_Object_List then
2529 Write_Str (Name_Buffer (1 .. Name_Len));
2533 -- Don't link with the shared library on VMS if an internal
2534 -- filename object is seen. Multiply defined symbols will
2537 if OpenVMS_On_Target
2538 and then Is_Internal_File_Name
2540 (Units.Table (Elab_Order.Table (E)).My_ALI).Sfile)
2542 -- Special case for g-trasym.obj (not included in libgnat)
2544 Get_Name_String (ALIs.Table
2545 (Units.Table (Elab_Order.Table (E)).My_ALI).Sfile);
2547 if Name_Buffer (1 .. 8) /= "g-trasym" then
2548 Opt.Shared_Libgnat := False;
2555 if Object_List_Filename /= null then
2559 -- Add a "-Ldir" for each directory in the object path
2560 if VM_Target /= CLI_Target then
2561 for J in 1 .. Nb_Dir_In_Obj_Search_Path loop
2563 Dir : constant String_Ptr := Dir_In_Obj_Search_Path (J);
2566 Add_Str_To_Name_Buffer ("-L");
2567 Add_Str_To_Name_Buffer (Dir.all);
2568 Write_Linker_Option;
2573 -- Sort linker options
2575 -- This sort accomplishes two important purposes:
2577 -- a) All application files are sorted to the front, and all GNAT
2578 -- internal files are sorted to the end. This results in a well
2579 -- defined dividing line between the two sets of files, for the
2580 -- purpose of inserting certain standard library references into
2581 -- the linker arguments list.
2583 -- b) Given two different units, we sort the linker options so that
2584 -- those from a unit earlier in the elaboration order comes later
2585 -- in the list. This is a heuristic designed to create a more
2586 -- friendly order of linker options when the operations appear in
2587 -- separate units. The idea is that if unit A must be elaborated
2588 -- before unit B, then it is more likely that B references
2589 -- libraries included by A, than vice versa, so we want libraries
2590 -- included by A to come after libraries included by B.
2592 -- These two criteria are implemented by function Lt_Linker_Option. Note
2593 -- that a special case of b) is that specs are elaborated before bodies,
2594 -- so linker options from specs come after linker options for bodies,
2595 -- and again, the assumption is that libraries used by the body are more
2596 -- likely to reference libraries used by the spec, than vice versa.
2599 (Linker_Options.Last,
2600 Move_Linker_Option'Access,
2601 Lt_Linker_Option'Access);
2603 -- Write user linker options, i.e. the set of linker options that come
2604 -- from all files other than GNAT internal files, Lgnat is left set to
2605 -- point to the first entry from a GNAT internal file, or past the end
2606 -- of the entries if there are no internal files.
2608 Lgnat := Linker_Options.Last + 1;
2610 for J in 1 .. Linker_Options.Last loop
2611 if not Linker_Options.Table (J).Internal_File then
2612 Get_Name_String (Linker_Options.Table (J).Name);
2613 Write_Linker_Option;
2620 -- Now we insert standard linker options that must appear after the
2621 -- entries from user files, and before the entries from GNAT run-time
2622 -- files. The reason for this decision is that libraries referenced
2623 -- by internal routines may reference these standard library entries.
2625 -- Note that we do not insert anything when pragma No_Run_Time has been
2626 -- specified or when the standard libraries are not to be used,
2627 -- otherwise on some platforms, such as VMS, we may get duplicate
2628 -- symbols when linking.
2630 if not (Opt.No_Run_Time_Mode or else Opt.No_Stdlib) then
2633 if Opt.Shared_Libgnat then
2634 Add_Str_To_Name_Buffer ("-shared");
2636 Add_Str_To_Name_Buffer ("-static");
2639 -- Write directly to avoid -K output (why???)
2641 Write_Info_Ada_C (" -- ", "", Name_Buffer (1 .. Name_Len));
2643 if With_DECGNAT then
2646 if Opt.Shared_Libgnat then
2647 Add_Str_To_Name_Buffer (Shared_Lib ("decgnat"));
2649 Add_Str_To_Name_Buffer ("-ldecgnat");
2652 Write_Linker_Option;
2658 if Opt.Shared_Libgnat then
2659 Add_Str_To_Name_Buffer (Shared_Lib ("gnarl"));
2661 Add_Str_To_Name_Buffer ("-lgnarl");
2664 Write_Linker_Option;
2669 if Opt.Shared_Libgnat then
2670 Add_Str_To_Name_Buffer (Shared_Lib ("gnat"));
2672 Add_Str_To_Name_Buffer ("-lgnat");
2675 Write_Linker_Option;
2678 -- Write linker options from all internal files
2680 for J in Lgnat .. Linker_Options.Last loop
2681 Get_Name_String (Linker_Options.Table (J).Name);
2682 Write_Linker_Option;
2685 if Output_Linker_Option_List and then not Zero_Formatting then
2689 if Ada_Bind_File then
2690 WBI ("-- END Object file/option list ");
2692 WBI (" END Object file/option list */");
2694 end Gen_Object_Files_Options;
2696 ---------------------
2697 -- Gen_Output_File --
2698 ---------------------
2700 procedure Gen_Output_File (Filename : String) is
2702 -- Acquire settings for Interrupt_State pragmas
2704 Set_IS_Pragma_Table;
2706 -- Acquire settings for Priority_Specific_Dispatching pragma
2708 Set_PSD_Pragma_Table;
2710 -- Override Ada_Bind_File and Bind_Main_Program for VMs since JGNAT only
2711 -- supports Ada code, and the main program is already generated by the
2714 if VM_Target /= No_VM then
2715 Ada_Bind_File := True;
2717 if VM_Target = JVM_Target then
2718 Bind_Main_Program := False;
2722 -- Override time slice value if -T switch is set
2724 if Time_Slice_Set then
2725 ALIs.Table (ALIs.First).Time_Slice_Value := Opt.Time_Slice_Value;
2728 -- Count number of elaboration calls
2730 for E in Elab_Order.First .. Elab_Order.Last loop
2731 if Units.Table (Elab_Order.Table (E)).No_Elab then
2734 Num_Elab_Calls := Num_Elab_Calls + 1;
2738 -- Generate output file in appropriate language
2740 Check_System_Restrictions_Used;
2742 if Ada_Bind_File then
2743 Gen_Output_File_Ada (Filename);
2745 Gen_Output_File_C (Filename);
2747 end Gen_Output_File;
2749 -------------------------
2750 -- Gen_Output_File_Ada --
2751 -------------------------
2753 procedure Gen_Output_File_Ada (Filename : String) is
2755 Ada_Main : constant String := Get_Ada_Main_Name;
2756 -- Name to be used for generated Ada main program. See the body of
2757 -- function Get_Ada_Main_Name for details on the form of the name.
2759 Needs_Library_Finalization : constant Boolean :=
2760 not Configurable_Run_Time_On_Target
2761 and then Has_Finalizer;
2762 -- For restricted run-time libraries (ZFP and Ravenscar) tasks are
2763 -- non-terminating, so we do not want finalization.
2766 -- Name of generated bind file (spec)
2769 -- Name of generated bind file (body)
2772 -- Create spec first
2774 Create_Binder_Output (Filename, 's', Bfiles);
2776 -- We always compile the binder file in Ada 95 mode so that we properly
2777 -- handle use of Ada 2005 keywords as identifiers in Ada 95 mode. None
2778 -- of the Ada 2005 constructs are needed by the binder file.
2780 WBI ("pragma Ada_95;");
2782 -- If we are operating in Restrictions (No_Exception_Handlers) mode,
2783 -- then we need to make sure that the binder program is compiled with
2784 -- the same restriction, so that no exception tables are generated.
2786 if Cumulative_Restrictions.Set (No_Exception_Handlers) then
2787 WBI ("pragma Restrictions (No_Exception_Handlers);");
2790 -- Same processing for Restrictions (No_Exception_Propagation)
2792 if Cumulative_Restrictions.Set (No_Exception_Propagation) then
2793 WBI ("pragma Restrictions (No_Exception_Propagation);");
2796 -- Same processing for pragma No_Run_Time
2798 if No_Run_Time_Mode then
2799 WBI ("pragma No_Run_Time;");
2802 -- Generate with of System so we can reference System.Address
2804 WBI ("with System;");
2806 -- Generate with of System.Initialize_Scalars if active
2808 if Initialize_Scalars_Used then
2809 WBI ("with System.Scalar_Values;");
2812 -- Generate with of System.Secondary_Stack if active
2814 if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then
2815 WBI ("with System.Secondary_Stack;");
2818 Resolve_Binder_Options;
2820 -- Usually, adafinal is called using a pragma Import C. Since Import C
2821 -- doesn't have the same semantics for JGNAT, we use standard Ada.
2823 if VM_Target /= No_VM
2824 and then not Suppress_Standard_Library_On_Target
2826 WBI ("with System.Soft_Links;");
2827 WBI ("with System.Standard_Library;");
2830 WBI ("package " & Ada_Main & " is");
2831 WBI (" pragma Warnings (Off);");
2833 -- Main program case
2835 if Bind_Main_Program then
2836 if VM_Target = No_VM then
2838 -- Generate argc/argv stuff unless suppressed
2840 if Command_Line_Args_On_Target
2841 or not Configurable_Run_Time_On_Target
2844 WBI (" gnat_argc : Integer;");
2845 WBI (" gnat_argv : System.Address;");
2846 WBI (" gnat_envp : System.Address;");
2848 -- If the standard library is not suppressed, these variables
2849 -- are in the run-time data area for easy run time access.
2851 if not Suppress_Standard_Library_On_Target then
2853 WBI (" pragma Import (C, gnat_argc);");
2854 WBI (" pragma Import (C, gnat_argv);");
2855 WBI (" pragma Import (C, gnat_envp);");
2859 -- Define exit status. Again in normal mode, this is in the
2860 -- run-time library, and is initialized there, but in the
2861 -- configurable runtime case, the variable is declared and
2862 -- initialized in this file.
2866 if Configurable_Run_Time_Mode then
2867 if Exit_Status_Supported_On_Target then
2868 WBI (" gnat_exit_status : Integer := 0;");
2872 WBI (" gnat_exit_status : Integer;");
2873 WBI (" pragma Import (C, gnat_exit_status);");
2877 -- Generate the GNAT_Version and Ada_Main_Program_Name info only for
2878 -- the main program. Otherwise, it can lead under some circumstances
2879 -- to a symbol duplication during the link (for instance when a C
2880 -- program uses two Ada libraries). Also zero terminate the string
2881 -- so that its end can be found reliably at run time.
2884 WBI (" GNAT_Version : constant String :=");
2885 WBI (" """ & Ver_Prefix &
2886 Gnat_Version_String &
2888 WBI (" pragma Export (C, GNAT_Version, ""__gnat_version"");");
2891 Set_String (" Ada_Main_Program_Name : constant String := """);
2892 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
2894 if VM_Target = No_VM then
2895 Set_Main_Program_Name;
2896 Set_String (""" & ASCII.NUL;");
2898 Set_String (Name_Buffer (1 .. Name_Len - 2) & """;");
2901 Write_Statement_Buffer;
2904 (" pragma Export (C, Ada_Main_Program_Name, " &
2905 """__gnat_ada_main_program_name"");");
2909 WBI (" procedure " & Ada_Init_Name.all & ";");
2910 WBI (" pragma Export (C, " & Ada_Init_Name.all & ", """ &
2911 Ada_Init_Name.all & """);");
2913 -- If -a has been specified use pragma Linker_Constructor for the init
2914 -- procedure and pragma Linker_Destructor for the final procedure.
2916 if Use_Pragma_Linker_Constructor then
2917 WBI (" pragma Linker_Constructor (" & Ada_Init_Name.all & ");");
2920 if not Cumulative_Restrictions.Set (No_Finalization) then
2922 WBI (" procedure " & Ada_Final_Name.all & ";");
2923 WBI (" pragma Export (C, " & Ada_Final_Name.all & ", """ &
2924 Ada_Final_Name.all & """);");
2926 if Use_Pragma_Linker_Constructor then
2927 WBI (" pragma Linker_Destructor (" & Ada_Final_Name.all & ");");
2931 if Bind_Main_Program and then VM_Target = No_VM then
2933 -- If we have the standard library, then Break_Start is defined
2934 -- there, but when the standard library is suppressed, Break_Start
2938 WBI (" procedure Break_Start;");
2940 if Suppress_Standard_Library_On_Target then
2941 WBI (" pragma Export (C, Break_Start, ""__gnat_break_start"");");
2943 WBI (" pragma Import (C, Break_Start, ""__gnat_break_start"");");
2948 if Exit_Status_Supported_On_Target then
2949 Set_String (" function ");
2951 Set_String (" procedure ");
2954 Set_String (Get_Main_Name);
2956 -- Generate argument list if present
2958 if Command_Line_Args_On_Target then
2959 Write_Statement_Buffer;
2960 WBI (" (argc : Integer;");
2961 WBI (" argv : System.Address;");
2963 (" envp : System.Address)");
2965 if Exit_Status_Supported_On_Target then
2966 Write_Statement_Buffer;
2967 WBI (" return Integer;");
2969 Write_Statement_Buffer (";");
2973 if Exit_Status_Supported_On_Target then
2974 Write_Statement_Buffer (" return Integer;");
2976 Write_Statement_Buffer (";");
2980 WBI (" pragma Export (C, " & Get_Main_Name & ", """ &
2981 Get_Main_Name & """);");
2990 WBI ("end " & Ada_Main & ";");
2991 Close_Binder_Output;
2993 -- Prepare to write body
2995 Create_Binder_Output (Filename, 'b', Bfileb);
2997 -- We always compile the binder file in Ada 95 mode so that we properly
2998 -- handle use of Ada 2005 keywords as identifiers in Ada 95 mode. None
2999 -- of the Ada 2005 constructs are needed by the binder file.
3001 WBI ("pragma Ada_95;");
3003 -- Output Source_File_Name pragmas which look like
3005 -- pragma Source_File_Name (Ada_Main, Spec_File_Name => "sss");
3006 -- pragma Source_File_Name (Ada_Main, Body_File_Name => "bbb");
3008 -- where sss/bbb are the spec/body file names respectively
3010 Get_Name_String (Bfiles);
3011 Name_Buffer (Name_Len + 1 .. Name_Len + 3) := """);";
3013 WBI ("pragma Source_File_Name (" &
3015 ", Spec_File_Name => """ &
3016 Name_Buffer (1 .. Name_Len + 3));
3018 Get_Name_String (Bfileb);
3019 Name_Buffer (Name_Len + 1 .. Name_Len + 3) := """);";
3021 WBI ("pragma Source_File_Name (" &
3023 ", Body_File_Name => """ &
3024 Name_Buffer (1 .. Name_Len + 3));
3026 -- Generate with of System.Restrictions to initialize
3027 -- Run_Time_Restrictions.
3029 if System_Restrictions_Used
3030 and not Suppress_Standard_Library_On_Target
3033 WBI ("with System.Restrictions;");
3036 if Needs_Library_Finalization then
3037 WBI ("with Ada.Exceptions;");
3041 WBI ("package body " & Ada_Main & " is");
3042 WBI (" pragma Warnings (Off);");
3045 -- Generate externals for elaboration entities
3046 Gen_Elab_Externals_Ada;
3048 if not Suppress_Standard_Library_On_Target then
3050 -- Generate Priority_Specific_Dispatching pragma string
3053 (" Local_Priority_Specific_Dispatching : constant String := """);
3055 for J in 0 .. PSD_Pragma_Settings.Last loop
3056 Set_Char (PSD_Pragma_Settings.Table (J));
3060 Write_Statement_Buffer;
3062 -- Generate Interrupt_State pragma string
3064 Set_String (" Local_Interrupt_States : constant String := """);
3066 for J in 0 .. IS_Pragma_Settings.Last loop
3067 Set_Char (IS_Pragma_Settings.Table (J));
3071 Write_Statement_Buffer;
3075 -- Generate the adafinal routine unless there is no finalization to do
3077 if not Cumulative_Restrictions.Set (No_Finalization) then
3078 if Needs_Library_Finalization then
3079 Gen_Finalize_Library_Ada;
3087 if Bind_Main_Program and then VM_Target = No_VM then
3089 -- When suppressing the standard library then generate dummy body
3092 if Suppress_Standard_Library_On_Target then
3094 WBI (" procedure Break_Start is");
3103 -- Output object file list and the Ada body is complete
3105 Gen_Object_Files_Options;
3108 WBI ("end " & Ada_Main & ";");
3110 Close_Binder_Output;
3111 end Gen_Output_File_Ada;
3113 -----------------------
3114 -- Gen_Output_File_C --
3115 -----------------------
3117 procedure Gen_Output_File_C (Filename : String) is
3119 Needs_Library_Finalization : constant Boolean :=
3120 not Configurable_Run_Time_On_Target
3121 and then Has_Finalizer;
3122 -- ??? seems like we repeat this cantation often, should it be global?
3125 pragma Warnings (Off, Bfile);
3126 -- Name of generated bind file (not referenced)
3129 Create_Binder_Output (Filename, 'c', Bfile);
3131 Resolve_Binder_Options;
3133 -- If -a has been specified use __attribute__((constructor)) for the
3134 -- init procedure and __attribute__((destructor)) for the final one.
3136 if Use_Pragma_Linker_Constructor then
3137 WBI ("extern void " & Ada_Init_Name.all &
3138 " (void) __attribute__((constructor));");
3140 WBI ("extern void " & Ada_Init_Name.all & " (void);");
3143 if not Cumulative_Restrictions.Set (No_Finalization) then
3144 if Use_Pragma_Linker_Constructor then
3145 WBI ("extern void " & Ada_Final_Name.all &
3146 " (void) __attribute__((destructor));");
3148 WBI ("extern void " & Ada_Final_Name.all & " (void);");
3152 WBI ("extern void system__standard_library__adafinal (void);");
3154 if not No_Main_Subprogram then
3155 Set_String ("extern ");
3157 if Exit_Status_Supported_On_Target then
3160 Set_String ("void");
3163 Set_String (" main ");
3165 if Command_Line_Args_On_Target then
3166 Write_Statement_Buffer ("(int, char **, char **);");
3168 Write_Statement_Buffer ("(void);");
3171 if OpenVMS_On_Target then
3172 WBI ("extern void decc$__posix_exit (int);");
3174 WBI ("extern void exit (int);");
3177 WBI ("extern void __gnat_break_start (void);");
3178 Set_String ("extern ");
3180 if ALIs.Table (ALIs.First).Main_Program = Proc then
3181 Set_String ("void ");
3183 Set_String ("int ");
3186 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
3187 Set_Main_Program_Name;
3188 Set_String (" (void);");
3189 Write_Statement_Buffer;
3192 if not Suppress_Standard_Library_On_Target then
3193 WBI ("extern void __gnat_initialize (void *);");
3194 WBI ("extern void __gnat_finalize (void);");
3195 WBI ("extern void __gnat_install_handler (void);");
3198 if Dynamic_Stack_Measurement then
3200 WBI ("extern void __gnat_stack_usage_output_results (void);");
3201 WBI ("extern void __gnat_stack_usage_initialize (int size);");
3204 -- Initialize stack limit for the environment task if the stack check
3205 -- method is stack limit and stack check is enabled.
3207 if Stack_Check_Limits_On_Target
3208 and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set)
3211 WBI ("extern void __gnat_initialize_stack_limit (void);");
3216 -- Generate externals for elaboration entities
3217 Gen_Elab_Externals_C;
3221 if Needs_Library_Finalization then
3222 Gen_Finalize_Library_Defs_C;
3225 -- Write argv/argc exit status stuff if main program case
3227 if Bind_Main_Program then
3229 -- First deal with argc/argv/envp. In the normal case they are in the
3230 -- run-time library.
3232 if not Configurable_Run_Time_On_Target then
3233 WBI ("extern int gnat_argc;");
3234 WBI ("extern char **gnat_argv;");
3235 WBI ("extern char **gnat_envp;");
3237 -- If configurable run time and no command line args, then the
3238 -- generation of these variables is entirely suppressed.
3240 elsif not Command_Line_Args_On_Target then
3243 -- Otherwise, in the configurable run-time case they are right in the
3247 WBI ("int gnat_argc;");
3248 WBI ("char **gnat_argv;");
3249 WBI ("char **gnat_envp;");
3252 -- Similarly deal with exit status
3254 if not Configurable_Run_Time_On_Target then
3255 WBI ("extern int gnat_exit_status;");
3257 -- If configurable run time and no exit status on target, then the
3258 -- generation of this variables is entirely suppressed.
3260 elsif not Exit_Status_Supported_On_Target then
3263 -- Otherwise, in the configurable run-time case this variable is
3264 -- right in the binder file, and initialized to zero there.
3267 WBI ("int gnat_exit_status = 0;");
3273 -- When suppressing the standard library, the __gnat_break_start routine
3274 -- (for the debugger to get initial control) is defined in this file.
3276 if Suppress_Standard_Library_On_Target then
3277 WBI ("void __gnat_break_start (void) {}");
3281 -- Generate the __gnat_version and __gnat_ada_main_program_name info
3282 -- only for the main program. Otherwise, it can lead under some
3283 -- circumstances to a symbol duplication during the link (for instance
3284 -- when a C program uses 2 Ada libraries)
3286 if Bind_Main_Program then
3287 WBI ("char __gnat_version[] = """ & Ver_Prefix &
3288 Gnat_Version_String & """;");
3290 Set_String ("char __gnat_ada_main_program_name[] = """);
3291 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
3292 Set_Main_Program_Name;
3294 Write_Statement_Buffer;
3298 -- Generate the adafinal routine unless there is no finalization to do
3300 if not Cumulative_Restrictions.Set (No_Finalization) then
3301 if Needs_Library_Finalization then
3302 Gen_Finalize_Library_C;
3310 -- Main is only present for Ada main case
3312 if Bind_Main_Program then
3316 -- Generate versions, elaboration order, list of object files
3320 Gen_Object_Files_Options;
3322 -- C binder output is complete
3324 Close_Binder_Output;
3325 end Gen_Output_File_C;
3327 --------------------------
3328 -- Gen_Restrictions_Ada --
3329 --------------------------
3331 procedure Gen_Restrictions_Ada is
3335 if Suppress_Standard_Library_On_Target
3336 or not System_Restrictions_Used
3341 WBI (" System.Restrictions.Run_Time_Restrictions :=");
3347 for J in Cumulative_Restrictions.Set'Range loop
3348 Set_Boolean (Cumulative_Restrictions.Set (J));
3352 if J /= Cumulative_Restrictions.Set'Last and then Count = 8 then
3353 Write_Statement_Buffer;
3359 Set_String_Replace ("),");
3360 Write_Statement_Buffer;
3361 Set_String (" Value => (");
3363 for J in Cumulative_Restrictions.Value'Range loop
3364 Set_Int (Int (Cumulative_Restrictions.Value (J)));
3368 Set_String_Replace ("),");
3369 Write_Statement_Buffer;
3370 WBI (" Violated =>");
3374 for J in Cumulative_Restrictions.Violated'Range loop
3375 Set_Boolean (Cumulative_Restrictions.Violated (J));
3379 if J /= Cumulative_Restrictions.Set'Last and then Count = 8 then
3380 Write_Statement_Buffer;
3386 Set_String_Replace ("),");
3387 Write_Statement_Buffer;
3388 Set_String (" Count => (");
3390 for J in Cumulative_Restrictions.Count'Range loop
3391 Set_Int (Int (Cumulative_Restrictions.Count (J)));
3395 Set_String_Replace ("),");
3396 Write_Statement_Buffer;
3397 Set_String (" Unknown => (");
3399 for J in Cumulative_Restrictions.Unknown'Range loop
3400 Set_Boolean (Cumulative_Restrictions.Unknown (J));
3404 Set_String_Replace ("))");
3406 Write_Statement_Buffer;
3407 end Gen_Restrictions_Ada;
3409 ------------------------
3410 -- Gen_Restrictions_C --
3411 ------------------------
3413 procedure Gen_Restrictions_C is
3415 if Suppress_Standard_Library_On_Target
3416 or not System_Restrictions_Used
3421 WBI (" typedef struct {");
3422 Set_String (" char set [");
3423 Set_Int (Cumulative_Restrictions.Set'Length);
3425 Write_Statement_Buffer;
3427 Set_String (" int value [");
3428 Set_Int (Cumulative_Restrictions.Value'Length);
3430 Write_Statement_Buffer;
3432 Set_String (" char violated [");
3433 Set_Int (Cumulative_Restrictions.Violated'Length);
3435 Write_Statement_Buffer;
3437 Set_String (" int count [");
3438 Set_Int (Cumulative_Restrictions.Count'Length);
3440 Write_Statement_Buffer;
3442 Set_String (" char unknown [");
3443 Set_Int (Cumulative_Restrictions.Unknown'Length);
3445 Write_Statement_Buffer;
3446 WBI (" } restrictions;");
3447 WBI (" extern restrictions " &
3448 "system__restrictions__run_time_restrictions;");
3449 WBI (" restrictions r = {");
3452 for J in Cumulative_Restrictions.Set'Range loop
3453 Set_Int (Boolean'Pos (Cumulative_Restrictions.Set (J)));
3457 Set_String_Replace ("},");
3458 Write_Statement_Buffer;
3461 for J in Cumulative_Restrictions.Value'Range loop
3462 Set_Int (Int (Cumulative_Restrictions.Value (J)));
3466 Set_String_Replace ("},");
3467 Write_Statement_Buffer;
3470 for J in Cumulative_Restrictions.Violated'Range loop
3471 Set_Int (Boolean'Pos (Cumulative_Restrictions.Violated (J)));
3475 Set_String_Replace ("},");
3476 Write_Statement_Buffer;
3479 for J in Cumulative_Restrictions.Count'Range loop
3480 Set_Int (Int (Cumulative_Restrictions.Count (J)));
3484 Set_String_Replace ("},");
3485 Write_Statement_Buffer;
3488 for J in Cumulative_Restrictions.Unknown'Range loop
3489 Set_Int (Boolean'Pos (Cumulative_Restrictions.Unknown (J)));
3493 Set_String_Replace ("}}");
3495 Write_Statement_Buffer;
3496 WBI (" system__restrictions__run_time_restrictions = r;");
3497 end Gen_Restrictions_C;
3499 ----------------------
3500 -- Gen_Versions_Ada --
3501 ----------------------
3503 -- This routine generates lines such as:
3505 -- unnnnn : constant Integer := 16#hhhhhhhh#;
3506 -- pragma Export (C, unnnnn, unam);
3508 -- for each unit, where unam is the unit name suffixed by either B or S for
3509 -- body or spec, with dots replaced by double underscores, and hhhhhhhh is
3510 -- the version number, and nnnnn is a 5-digits serial number.
3512 procedure Gen_Versions_Ada is
3513 Ubuf : String (1 .. 6) := "u00000";
3515 procedure Increment_Ubuf;
3516 -- Little procedure to increment the serial number
3518 --------------------
3519 -- Increment_Ubuf --
3520 --------------------
3522 procedure Increment_Ubuf is
3524 for J in reverse Ubuf'Range loop
3525 Ubuf (J) := Character'Succ (Ubuf (J));
3526 exit when Ubuf (J) <= '9';
3531 -- Start of processing for Gen_Versions_Ada
3536 WBI (" type Version_32 is mod 2 ** 32;");
3537 for U in Units.First .. Units.Last loop
3538 if not Units.Table (U).SAL_Interface and then
3539 ((not Bind_For_Library) or else Units.Table (U).Directly_Scanned)
3542 WBI (" " & Ubuf & " : constant Version_32 := 16#" &
3543 Units.Table (U).Version & "#;");
3544 Set_String (" pragma Export (C, ");
3546 Set_String (", """);
3548 Get_Name_String (Units.Table (U).Uname);
3550 for K in 1 .. Name_Len loop
3551 if Name_Buffer (K) = '.' then
3555 elsif Name_Buffer (K) = '%' then
3559 Set_Char (Name_Buffer (K));
3563 if Name_Buffer (Name_Len) = 's' then
3569 Set_String (""");");
3570 Write_Statement_Buffer;
3573 end Gen_Versions_Ada;
3575 --------------------
3576 -- Gen_Versions_C --
3577 --------------------
3579 -- This routine generates a line of the form:
3581 -- unsigned unam = 0xhhhhhhhh;
3583 -- for each unit, where unam is the unit name suffixed by either B or S for
3584 -- body or spec, with dots replaced by double underscores.
3586 procedure Gen_Versions_C is
3588 for U in Units.First .. Units.Last loop
3589 if not Units.Table (U).SAL_Interface and then
3590 ((not Bind_For_Library) or else Units.Table (U).Directly_Scanned)
3592 Set_String ("unsigned ");
3594 Get_Name_String (Units.Table (U).Uname);
3596 for K in 1 .. Name_Len loop
3597 if Name_Buffer (K) = '.' then
3600 elsif Name_Buffer (K) = '%' then
3604 Set_Char (Name_Buffer (K));
3608 if Name_Buffer (Name_Len) = 's' then
3614 Set_String (" = 0x");
3615 Set_String (Units.Table (U).Version);
3617 Write_Statement_Buffer;
3622 ------------------------
3623 -- Get_Main_Unit_Name --
3624 ------------------------
3626 function Get_Main_Unit_Name (S : String) return String is
3627 Result : String := S;
3630 for J in S'Range loop
3631 if Result (J) = '.' then
3637 end Get_Main_Unit_Name;
3639 -----------------------
3640 -- Get_Ada_Main_Name --
3641 -----------------------
3643 function Get_Ada_Main_Name return String is
3644 Suffix : constant String := "_00";
3645 Name : String (1 .. Opt.Ada_Main_Name.all'Length + Suffix'Length) :=
3646 Opt.Ada_Main_Name.all & Suffix;
3650 -- The main program generated by JGNAT expects a package called
3651 -- ada_<main procedure>.
3653 if VM_Target /= No_VM then
3654 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
3655 return "ada_" & Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len - 2));
3658 -- This loop tries the following possibilities in order
3664 -- where <Ada_Main> is equal to Opt.Ada_Main_Name. By default,
3665 -- it is set to 'ada_main'.
3667 for J in 0 .. 99 loop
3669 Nlen := Name'Length - Suffix'Length;
3671 Nlen := Name'Length;
3672 Name (Name'Last) := Character'Val (J mod 10 + Character'Pos ('0'));
3673 Name (Name'Last - 1) :=
3674 Character'Val (J / 10 + Character'Pos ('0'));
3677 for K in ALIs.First .. ALIs.Last loop
3678 for L in ALIs.Table (K).First_Unit .. ALIs.Table (K).Last_Unit loop
3680 -- Get unit name, removing %b or %e at end
3682 Get_Name_String (Units.Table (L).Uname);
3683 Name_Len := Name_Len - 2;
3685 if Name_Buffer (1 .. Name_Len) = Name (1 .. Nlen) then
3691 return Name (1 .. Nlen);
3697 -- If we fall through, just use a peculiar unlikely name
3699 return ("Qwertyuiop");
3700 end Get_Ada_Main_Name;
3706 function Get_Main_Name return String is
3708 -- Explicit name given with -M switch
3710 if Bind_Alternate_Main_Name then
3711 return Alternate_Main_Name.all;
3713 -- Case of main program name to be used directly
3715 elsif Use_Ada_Main_Program_Name_On_Target then
3717 -- Get main program name
3719 Get_Name_String (Units.Table (First_Unit_Entry).Uname);
3721 -- If this is a child name, return only the name of the child, since
3722 -- we can't have dots in a nested program name. Note that we do not
3723 -- include the %b at the end of the unit name.
3725 for J in reverse 1 .. Name_Len - 2 loop
3726 if J = 1 or else Name_Buffer (J - 1) = '.' then
3727 return Name_Buffer (J .. Name_Len - 2);
3731 raise Program_Error; -- impossible exit
3733 -- Case where "main" is to be used as default
3740 ---------------------
3741 -- Get_WC_Encoding --
3742 ---------------------
3744 function Get_WC_Encoding return Character is
3746 -- If encoding method specified by -W switch, then return it
3748 if Wide_Character_Encoding_Method_Specified then
3749 return WC_Encoding_Letters (Wide_Character_Encoding_Method);
3751 -- If no main program, and not specified, set brackets, we really have
3752 -- no better choice. If some other encoding is required when there is
3753 -- no main, it must be set explicitly using -Wx.
3755 -- Note: if the ALI file always passed the wide character encoding of
3756 -- every file, then we could use the encoding of the initial specified
3757 -- file, but this information is passed only for potential main
3758 -- programs. We could fix this sometime, but it is a very minor point
3759 -- (wide character default encoding for [Wide_[Wide_]Text_IO when there
3760 -- is no main program).
3762 elsif No_Main_Subprogram then
3765 -- Otherwise if there is a main program, take encoding from it
3768 return ALIs.Table (ALIs.First).WC_Encoding;
3770 end Get_WC_Encoding;
3776 function Has_Finalizer return Boolean is
3781 for E in reverse Elab_Order.First .. Elab_Order.Last loop
3782 Unum := Elab_Order.Table (E);
3783 U := Units.Table (Unum);
3785 -- We are only interested in non-generic packages
3787 if U.Unit_Kind = 'p'
3788 and then U.Has_Finalizer
3789 and then not U.Is_Generic
3790 and then not U.No_Elab
3799 ----------------------
3800 -- Lt_Linker_Option --
3801 ----------------------
3803 function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean is
3805 -- Sort internal files last
3807 if Linker_Options.Table (Op1).Internal_File
3809 Linker_Options.Table (Op2).Internal_File
3811 -- Note: following test uses False < True
3813 return Linker_Options.Table (Op1).Internal_File
3815 Linker_Options.Table (Op2).Internal_File;
3817 -- If both internal or both non-internal, sort according to the
3818 -- elaboration position. A unit that is elaborated later should come
3819 -- earlier in the linker options list.
3822 return Units.Table (Linker_Options.Table (Op1).Unit).Elab_Position
3824 Units.Table (Linker_Options.Table (Op2).Unit).Elab_Position;
3827 end Lt_Linker_Option;
3829 ------------------------
3830 -- Move_Linker_Option --
3831 ------------------------
3833 procedure Move_Linker_Option (From : Natural; To : Natural) is
3835 Linker_Options.Table (To) := Linker_Options.Table (From);
3836 end Move_Linker_Option;
3838 ----------------------------
3839 -- Resolve_Binder_Options --
3840 ----------------------------
3842 procedure Resolve_Binder_Options is
3844 for E in Elab_Order.First .. Elab_Order.Last loop
3845 Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
3847 -- This is not a perfect approach, but is the current protocol
3848 -- between the run-time and the binder to indicate that tasking is
3849 -- used: system.os_interface should always be used by any tasking
3852 if Name_Buffer (1 .. 19) = "system.os_interface" then
3856 -- Ditto for declib and the "dec" package
3858 if OpenVMS_On_Target and then Name_Buffer (1 .. 5) = "dec%s" then
3859 With_DECGNAT := True;
3862 end Resolve_Binder_Options;
3868 procedure Set_Boolean (B : Boolean) is
3869 True_Str : constant String := "True";
3870 False_Str : constant String := "False";
3873 Statement_Buffer (Last + 1 .. Last + True_Str'Length) := True_Str;
3874 Last := Last + True_Str'Length;
3876 Statement_Buffer (Last + 1 .. Last + False_Str'Length) := False_Str;
3877 Last := Last + False_Str'Length;
3885 procedure Set_Char (C : Character) is
3888 Statement_Buffer (Last) := C;
3895 procedure Set_Int (N : Int) is
3907 Statement_Buffer (Last) :=
3908 Character'Val (N mod 10 + Character'Pos ('0'));
3912 -------------------------
3913 -- Set_IS_Pragma_Table --
3914 -------------------------
3916 procedure Set_IS_Pragma_Table is
3918 for F in ALIs.First .. ALIs.Last loop
3919 for K in ALIs.Table (F).First_Interrupt_State ..
3920 ALIs.Table (F).Last_Interrupt_State
3923 Inum : constant Int :=
3924 Interrupt_States.Table (K).Interrupt_Id;
3925 Stat : constant Character :=
3926 Interrupt_States.Table (K).Interrupt_State;
3929 while IS_Pragma_Settings.Last < Inum loop
3930 IS_Pragma_Settings.Append ('n');
3933 IS_Pragma_Settings.Table (Inum) := Stat;
3937 end Set_IS_Pragma_Table;
3939 ---------------------------
3940 -- Set_Main_Program_Name --
3941 ---------------------------
3943 procedure Set_Main_Program_Name is
3945 -- Note that name has %b on the end which we ignore
3947 -- First we output the initial _ada_ since we know that the main
3948 -- program is a library level subprogram.
3950 Set_String ("_ada_");
3952 -- Copy name, changing dots to double underscores
3954 for J in 1 .. Name_Len - 2 loop
3955 if Name_Buffer (J) = '.' then
3958 Set_Char (Name_Buffer (J));
3961 end Set_Main_Program_Name;
3963 ---------------------
3964 -- Set_Name_Buffer --
3965 ---------------------
3967 procedure Set_Name_Buffer is
3969 for J in 1 .. Name_Len loop
3970 Set_Char (Name_Buffer (J));
3972 end Set_Name_Buffer;
3974 -------------------------
3975 -- Set_PSD_Pragma_Table --
3976 -------------------------
3978 procedure Set_PSD_Pragma_Table is
3980 for F in ALIs.First .. ALIs.Last loop
3981 for K in ALIs.Table (F).First_Specific_Dispatching ..
3982 ALIs.Table (F).Last_Specific_Dispatching
3985 DTK : Specific_Dispatching_Record
3986 renames Specific_Dispatching.Table (K);
3989 while PSD_Pragma_Settings.Last < DTK.Last_Priority loop
3990 PSD_Pragma_Settings.Append ('F');
3993 for Prio in DTK.First_Priority .. DTK.Last_Priority loop
3994 PSD_Pragma_Settings.Table (Prio) := DTK.Dispatching_Policy;
3999 end Set_PSD_Pragma_Table;
4005 procedure Set_String (S : String) is
4007 Statement_Buffer (Last + 1 .. Last + S'Length) := S;
4008 Last := Last + S'Length;
4011 ------------------------
4012 -- Set_String_Replace --
4013 ------------------------
4015 procedure Set_String_Replace (S : String) is
4017 Statement_Buffer (Last - S'Length + 1 .. Last) := S;
4018 end Set_String_Replace;
4024 procedure Set_Unit_Name (Mode : Qualification_Mode := Double_Underscores) is
4026 for J in 1 .. Name_Len - 2 loop
4027 if Name_Buffer (J) = '.' then
4028 if Mode = Double_Underscores then
4030 elsif Mode = Dot then
4036 Set_Char (Name_Buffer (J));
4041 ---------------------
4042 -- Set_Unit_Number --
4043 ---------------------
4045 procedure Set_Unit_Number (U : Unit_Id) is
4046 Num_Units : constant Nat := Nat (Units.Last) - Nat (Unit_Id'First);
4047 Unum : constant Nat := Nat (U) - Nat (Unit_Id'First);
4050 if Num_Units >= 10 and then Unum < 10 then
4054 if Num_Units >= 100 and then Unum < 100 then
4059 end Set_Unit_Number;
4061 ----------------------
4062 -- Write_Info_Ada_C --
4063 ----------------------
4065 procedure Write_Info_Ada_C (Ada : String; C : String; Common : String) is
4067 if Ada_Bind_File then
4069 S : String (1 .. Ada'Length + Common'Length);
4071 S (1 .. Ada'Length) := Ada;
4072 S (Ada'Length + 1 .. S'Length) := Common;
4078 S : String (1 .. C'Length + Common'Length);
4080 S (1 .. C'Length) := C;
4081 S (C'Length + 1 .. S'Length) := Common;
4085 end Write_Info_Ada_C;
4087 ----------------------------
4088 -- Write_Statement_Buffer --
4089 ----------------------------
4091 procedure Write_Statement_Buffer is
4093 WBI (Statement_Buffer (1 .. Last));
4095 end Write_Statement_Buffer;
4097 procedure Write_Statement_Buffer (S : String) is
4100 Write_Statement_Buffer;
4101 end Write_Statement_Buffer;