1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- B I N D G E N -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- 10-- -- 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. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with ALI; use ALI; 27with Binde; use Binde; 28with Casing; use Casing; 29with Fname; use Fname; 30with Gnatvsn; use Gnatvsn; 31with Hostparm; 32with Namet; use Namet; 33with Opt; use Opt; 34with Osint; use Osint; 35with Osint.B; use Osint.B; 36with Output; use Output; 37with Rident; use Rident; 38with Table; use Table; 39with Targparm; use Targparm; 40with Types; use Types; 41 42with System.OS_Lib; use System.OS_Lib; 43with System.WCh_Con; use System.WCh_Con; 44 45with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A; 46 47package body Bindgen is 48 49 Statement_Buffer : String (1 .. 1000); 50 -- Buffer used for constructing output statements 51 52 Last : Natural := 0; 53 -- Last location in Statement_Buffer currently set 54 55 With_GNARL : Boolean := False; 56 -- Flag which indicates whether the program uses the GNARL library 57 -- (presence of the unit System.OS_Interface) 58 59 Num_Elab_Calls : Nat := 0; 60 -- Number of generated calls to elaboration routines 61 62 System_Restrictions_Used : Boolean := False; 63 -- Flag indicating whether the unit System.Restrictions is in the closure 64 -- of the partition. This is set by Resolve_Binder_Options, and is used 65 -- to determine whether or not to initialize the restrictions information 66 -- in the body of the binder generated file (we do not want to do this 67 -- unconditionally, since it drags in the System.Restrictions unit 68 -- unconditionally, which is unpleasand, especially for ZFP etc.) 69 70 Dispatching_Domains_Used : Boolean := False; 71 -- Flag indicating whether multiprocessor dispatching domains are used in 72 -- the closure of the partition. This is set by Resolve_Binder_Options, and 73 -- is used to call the routine to disallow the creation of new dispatching 74 -- domains just before calling the main procedure from the environment 75 -- task. 76 77 System_Tasking_Restricted_Stages_Used : Boolean := False; 78 -- Flag indicating whether the unit System.Tasking.Restricted.Stages is in 79 -- the closure of the partition. This is set by Resolve_Binder_Options, 80 -- and it used to call a routine to active all the tasks at the end of 81 -- the elaboration when partition elaboration policy is sequential. 82 83 System_Interrupts_Used : Boolean := False; 84 -- Flag indicating whether the unit System.Interrups is in the closure of 85 -- the partition. This is set by Resolve_Binder_Options, and it used to 86 -- attach interrupt handlers at the end of the elaboration when partition 87 -- elaboration policy is sequential. 88 89 Lib_Final_Built : Boolean := False; 90 -- Flag indicating whether the finalize_library rountine has been built 91 92 CodePeer_Wrapper_Name : constant String := "call_main_subprogram"; 93 -- For CodePeer, introduce a wrapper subprogram which calls the 94 -- user-defined main subprogram. 95 96 ---------------------------------- 97 -- Interface_State Pragma Table -- 98 ---------------------------------- 99 100 -- This table assembles the interface state pragma information from 101 -- all the units in the partition. Note that Bcheck has already checked 102 -- that the information is consistent across units. The entries 103 -- in this table are n/u/r/s for not set/user/runtime/system. 104 105 package IS_Pragma_Settings is new Table.Table ( 106 Table_Component_Type => Character, 107 Table_Index_Type => Int, 108 Table_Low_Bound => 0, 109 Table_Initial => 100, 110 Table_Increment => 200, 111 Table_Name => "IS_Pragma_Settings"); 112 113 -- This table assembles the Priority_Specific_Dispatching pragma 114 -- information from all the units in the partition. Note that Bcheck has 115 -- already checked that the information is consistent across units. 116 -- The entries in this table are the upper case first character of the 117 -- policy name, e.g. 'F' for FIFO_Within_Priorities. 118 119 package PSD_Pragma_Settings is new Table.Table ( 120 Table_Component_Type => Character, 121 Table_Index_Type => Int, 122 Table_Low_Bound => 0, 123 Table_Initial => 100, 124 Table_Increment => 200, 125 Table_Name => "PSD_Pragma_Settings"); 126 127 ---------------------- 128 -- Run-Time Globals -- 129 ---------------------- 130 131 -- This section documents the global variables that are set from the 132 -- generated binder file. 133 134 -- Main_Priority : Integer; 135 -- Time_Slice_Value : Integer; 136 -- Heap_Size : Natural; 137 -- WC_Encoding : Character; 138 -- Locking_Policy : Character; 139 -- Queuing_Policy : Character; 140 -- Task_Dispatching_Policy : Character; 141 -- Priority_Specific_Dispatching : System.Address; 142 -- Num_Specific_Dispatching : Integer; 143 -- Restrictions : System.Address; 144 -- Interrupt_States : System.Address; 145 -- Num_Interrupt_States : Integer; 146 -- Unreserve_All_Interrupts : Integer; 147 -- Exception_Tracebacks : Integer; 148 -- Detect_Blocking : Integer; 149 -- Default_Stack_Size : Integer; 150 -- Leap_Seconds_Support : Integer; 151 -- Main_CPU : Integer; 152 153 -- Main_Priority is the priority value set by pragma Priority in the main 154 -- program. If no such pragma is present, the value is -1. 155 156 -- Time_Slice_Value is the time slice value set by pragma Time_Slice in the 157 -- main program, or by the use of a -Tnnn parameter for the binder (if both 158 -- are present, the binder value overrides). The value is in milliseconds. 159 -- A value of zero indicates that time slicing should be suppressed. If no 160 -- pragma is present, and no -T switch was used, the value is -1. 161 162 -- WC_Encoding shows the wide character encoding method used for the main 163 -- program. This is one of the encoding letters defined in 164 -- System.WCh_Con.WC_Encoding_Letters. 165 166 -- Locking_Policy is a space if no locking policy was specified for the 167 -- partition. If a locking policy was specified, the value is the upper 168 -- case first character of the locking policy name, for example, 'C' for 169 -- Ceiling_Locking. 170 171 -- Queuing_Policy is a space if no queuing policy was specified for the 172 -- partition. If a queuing policy was specified, the value is the upper 173 -- case first character of the queuing policy name for example, 'F' for 174 -- FIFO_Queuing. 175 176 -- Task_Dispatching_Policy is a space if no task dispatching policy was 177 -- specified for the partition. If a task dispatching policy was specified, 178 -- the value is the upper case first character of the policy name, e.g. 'F' 179 -- for FIFO_Within_Priorities. 180 181 -- Priority_Specific_Dispatching is the address of a string used to store 182 -- the task dispatching policy specified for the different priorities in 183 -- the partition. The length of this string is determined by the last 184 -- priority for which such a pragma applies (the string will be a null 185 -- string if no specific dispatching policies were used). If pragma were 186 -- present, the entries apply to the priorities in sequence from the first 187 -- priority. The value stored is the upper case first character of the 188 -- policy name, or 'F' (for FIFO_Within_Priorities) as the default value 189 -- for those priority ranges not specified. 190 191 -- Num_Specific_Dispatching is length of the Priority_Specific_Dispatching 192 -- string. It will be set to zero if no Priority_Specific_Dispatching 193 -- pragmas are present. 194 195 -- Restrictions is the address of a null-terminated string specifying the 196 -- restrictions information for the partition. The format is identical to 197 -- that of the parameter string found on R lines in ali files (see Lib.Writ 198 -- spec in lib-writ.ads for full details). The difference is that in this 199 -- context the values are the cumulative ones for the entire partition. 200 201 -- Interrupt_States is the address of a string used to specify the 202 -- cumulative results of Interrupt_State pragmas used in the partition. 203 -- The length of this string is determined by the last interrupt for which 204 -- such a pragma is given (the string will be a null string if no pragmas 205 -- were used). If pragma were present the entries apply to the interrupts 206 -- in sequence from the first interrupt, and are set to one of four 207 -- possible settings: 'n' for not specified, 'u' for user, 'r' for run 208 -- time, 's' for system, see description of Interrupt_State pragma for 209 -- further details. 210 211 -- Num_Interrupt_States is the length of the Interrupt_States string. It 212 -- will be set to zero if no Interrupt_State pragmas are present. 213 214 -- Unreserve_All_Interrupts is set to one if at least one unit in the 215 -- partition had a pragma Unreserve_All_Interrupts, and zero otherwise. 216 217 -- Exception_Tracebacks is set to one if the -E parameter was present 218 -- in the bind and to zero otherwise. Note that on some targets exception 219 -- tracebacks are provided by default, so a value of zero for this 220 -- parameter does not necessarily mean no trace backs are available. 221 222 -- Detect_Blocking indicates whether pragma Detect_Blocking is active or 223 -- not. A value of zero indicates that the pragma is not present, while a 224 -- value of 1 signals its presence in the partition. 225 226 -- Default_Stack_Size is the default stack size used when creating an Ada 227 -- task with no explicit Storage_Size clause. 228 229 -- Leap_Seconds_Support denotes whether leap seconds have been enabled or 230 -- disabled. A value of zero indicates that leap seconds are turned "off", 231 -- while a value of one signifies "on" status. 232 233 -- Main_CPU is the processor set by pragma CPU in the main program. If no 234 -- such pragma is present, the value is -1. 235 236 procedure WBI (Info : String) renames Osint.B.Write_Binder_Info; 237 -- Convenient shorthand used throughout 238 239 ----------------------- 240 -- Local Subprograms -- 241 ----------------------- 242 243 procedure Gen_Adainit; 244 -- Generates the Adainit procedure 245 246 procedure Gen_Adafinal; 247 -- Generate the Adafinal procedure 248 249 procedure Gen_CodePeer_Wrapper; 250 -- For CodePeer, generate wrapper which calls user-defined main subprogram 251 252 procedure Gen_Elab_Calls; 253 -- Generate sequence of elaboration calls 254 255 procedure Gen_Elab_Externals; 256 -- Generate sequence of external declarations for elaboration 257 258 procedure Gen_Elab_Order; 259 -- Generate comments showing elaboration order chosen 260 261 procedure Gen_Finalize_Library; 262 -- Generate a sequence of finalization calls to elaborated packages 263 264 procedure Gen_Main; 265 -- Generate procedure main 266 267 procedure Gen_Object_Files_Options; 268 -- Output comments containing a list of the full names of the object 269 -- files to be linked and the list of linker options supplied by 270 -- Linker_Options pragmas in the source. 271 272 procedure Gen_Output_File_Ada (Filename : String); 273 -- Generate Ada output file 274 275 procedure Gen_Restrictions; 276 -- Generate initialization of restrictions variable 277 278 procedure Gen_Versions; 279 -- Output series of definitions for unit versions 280 281 function Get_Ada_Main_Name return String; 282 -- This function is used for the Ada main output to compute a usable name 283 -- for the generated main program. The normal main program name is 284 -- Ada_Main, but this won't work if the user has a unit with this name. 285 -- This function tries Ada_Main first, and if there is such a clash, then 286 -- it tries Ada_Name_01, Ada_Name_02 ... Ada_Name_99 in sequence. 287 288 function Get_Main_Unit_Name (S : String) return String; 289 -- Return the main unit name corresponding to S by replacing '.' with '_' 290 291 function Get_Main_Name return String; 292 -- This function is used in the main output case to compute the correct 293 -- external main program. It is "main" by default, unless the flag 294 -- Use_Ada_Main_Program_Name_On_Target is set, in which case it is the name 295 -- of the Ada main name without the "_ada". This default can be overridden 296 -- explicitly using the -Mname binder switch. 297 298 function Get_WC_Encoding return Character; 299 -- Return wide character encoding method to set as WC_Encoding in output. 300 -- If -W has been used, returns the specified encoding, otherwise returns 301 -- the encoding method used for the main program source. If there is no 302 -- main program source (-z switch used), returns brackets ('b'). 303 304 function Has_Finalizer return Boolean; 305 -- Determine whether the current unit has at least one library-level 306 -- finalizer. 307 308 function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean; 309 -- Compare linker options, when sorting, first according to 310 -- Is_Internal_File (internal files come later) and then by 311 -- elaboration order position (latest to earliest). 312 313 procedure Move_Linker_Option (From : Natural; To : Natural); 314 -- Move routine for sorting linker options 315 316 procedure Resolve_Binder_Options; 317 -- Set the value of With_GNARL 318 319 procedure Set_Char (C : Character); 320 -- Set given character in Statement_Buffer at the Last + 1 position 321 -- and increment Last by one to reflect the stored character. 322 323 procedure Set_Int (N : Int); 324 -- Set given value in decimal in Statement_Buffer with no spaces starting 325 -- at the Last + 1 position, and updating Last past the value. A minus sign 326 -- is output for a negative value. 327 328 procedure Set_Boolean (B : Boolean); 329 -- Set given boolean value in Statement_Buffer at the Last + 1 position 330 -- and update Last past the value. 331 332 procedure Set_IS_Pragma_Table; 333 -- Initializes contents of IS_Pragma_Settings table from ALI table 334 335 procedure Set_Main_Program_Name; 336 -- Given the main program name in Name_Buffer (length in Name_Len) generate 337 -- the name of the routine to be used in the call. The name is generated 338 -- starting at Last + 1, and Last is updated past it. 339 340 procedure Set_Name_Buffer; 341 -- Set the value stored in positions 1 .. Name_Len of the Name_Buffer 342 343 procedure Set_PSD_Pragma_Table; 344 -- Initializes contents of PSD_Pragma_Settings table from ALI table 345 346 procedure Set_String (S : String); 347 -- Sets characters of given string in Statement_Buffer, starting at the 348 -- Last + 1 position, and updating last past the string value. 349 350 procedure Set_String_Replace (S : String); 351 -- Replaces the last S'Length characters in the Statement_Buffer with the 352 -- characters of S. The caller must ensure that these characters do in fact 353 -- exist in the Statement_Buffer. 354 355 type Qualification_Mode is (Dollar_Sign, Dot, Double_Underscores); 356 357 procedure Set_Unit_Name (Mode : Qualification_Mode := Double_Underscores); 358 -- Given a unit name in the Name_Buffer, copy it into Statement_Buffer, 359 -- starting at the Last + 1 position and update Last past the value. 360 -- Depending on parameter Mode, a dot (.) can be qualified into double 361 -- underscores (__), a dollar sign ($) or left as is. 362 363 procedure Set_Unit_Number (U : Unit_Id); 364 -- Sets unit number (first unit is 1, leading zeroes output to line up all 365 -- output unit numbers nicely as required by the value, and by the total 366 -- number of units. 367 368 procedure Write_Statement_Buffer; 369 -- Write out contents of statement buffer up to Last, and reset Last to 0 370 371 procedure Write_Statement_Buffer (S : String); 372 -- First writes its argument (using Set_String (S)), then writes out the 373 -- contents of statement buffer up to Last, and reset Last to 0 374 375 ------------------ 376 -- Gen_Adafinal -- 377 ------------------ 378 379 procedure Gen_Adafinal is 380 begin 381 WBI (" procedure " & Ada_Final_Name.all & " is"); 382 383 if VM_Target = No_VM 384 and Bind_Main_Program 385 and not CodePeer_Mode 386 then 387 WBI (" procedure s_stalib_adafinal;"); 388 Set_String (" pragma Import (C, s_stalib_adafinal, "); 389 Set_String ("""system__standard_library__adafinal"");"); 390 Write_Statement_Buffer; 391 end if; 392 393 WBI (""); 394 WBI (" procedure Runtime_Finalize;"); 395 WBI (" pragma Import (C, Runtime_Finalize, " & 396 """__gnat_runtime_finalize"");"); 397 WBI (""); 398 WBI (" begin"); 399 400 if not CodePeer_Mode then 401 WBI (" if not Is_Elaborated then"); 402 WBI (" return;"); 403 WBI (" end if;"); 404 WBI (" Is_Elaborated := False;"); 405 end if; 406 407 WBI (" Runtime_Finalize;"); 408 409 -- On non-virtual machine targets, finalization is done differently 410 -- depending on whether this is the main program or a library. 411 412 if VM_Target = No_VM and then not CodePeer_Mode then 413 if Bind_Main_Program then 414 WBI (" s_stalib_adafinal;"); 415 elsif Lib_Final_Built then 416 WBI (" finalize_library;"); 417 else 418 WBI (" null;"); 419 end if; 420 421 -- Pragma Import C cannot be used on virtual machine targets, therefore 422 -- call the runtime finalization routine directly. Similarly in CodePeer 423 -- mode, where imported functions are ignored. 424 425 else 426 WBI (" System.Standard_Library.Adafinal;"); 427 end if; 428 429 WBI (" end " & Ada_Final_Name.all & ";"); 430 WBI (""); 431 end Gen_Adafinal; 432 433 ----------------- 434 -- Gen_Adainit -- 435 ----------------- 436 437 procedure Gen_Adainit is 438 Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority; 439 Main_CPU : Int renames ALIs.Table (ALIs.First).Main_CPU; 440 441 begin 442 -- Declare the access-to-subprogram type used for initialization of 443 -- of __gnat_finalize_library_objects. This is declared at library 444 -- level for compatibility with the type used in System.Soft_Links. 445 -- The import of the soft link which performs library-level object 446 -- finalization is not needed for VM targets; regular Ada is used in 447 -- that case. For restricted run-time libraries (ZFP and Ravenscar) 448 -- tasks are non-terminating, so we do not want finalization. 449 450 if not Suppress_Standard_Library_On_Target 451 and then VM_Target = No_VM 452 and then not CodePeer_Mode 453 and then not Configurable_Run_Time_On_Target 454 then 455 WBI (" type No_Param_Proc is access procedure;"); 456 WBI (""); 457 end if; 458 459 WBI (" procedure " & Ada_Init_Name.all & " is"); 460 461 -- In CodePeer mode, simplify adainit procedure by only calling 462 -- elaboration procedures. 463 464 if CodePeer_Mode then 465 WBI (" begin"); 466 467 -- When compiling for the AAMP small library, where the standard library 468 -- is no longer suppressed, we still want to exclude the setting of the 469 -- various imported globals, which aren't present for that library. 470 471 elsif AAMP_On_Target and then Configurable_Run_Time_On_Target then 472 WBI (" begin"); 473 WBI (" null;"); 474 475 -- If the standard library is suppressed, then the only global variables 476 -- that might be needed (by the Ravenscar profile) are the priority and 477 -- the processor for the environment task. 478 479 elsif Suppress_Standard_Library_On_Target then 480 if Main_Priority /= No_Main_Priority then 481 WBI (" Main_Priority : Integer;"); 482 WBI (" pragma Import (C, Main_Priority," & 483 " ""__gl_main_priority"");"); 484 WBI (""); 485 end if; 486 487 if Main_CPU /= No_Main_CPU then 488 WBI (" Main_CPU : Integer;"); 489 WBI (" pragma Import (C, Main_CPU," & 490 " ""__gl_main_cpu"");"); 491 WBI (""); 492 end if; 493 494 if System_Interrupts_Used 495 and then Partition_Elaboration_Policy_Specified = 'S' 496 then 497 WBI (" procedure Install_Restricted_Handlers_Sequential;"); 498 WBI (" pragma Import (C," & 499 "Install_Restricted_Handlers_Sequential," & 500 " ""__gnat_attach_all_handlers"");"); 501 WBI (""); 502 end if; 503 504 if System_Tasking_Restricted_Stages_Used 505 and then Partition_Elaboration_Policy_Specified = 'S' 506 then 507 WBI (" Partition_Elaboration_Policy : Character;"); 508 WBI (" pragma Import (C, Partition_Elaboration_Policy," & 509 " ""__gnat_partition_elaboration_policy"");"); 510 WBI (""); 511 WBI (" procedure Activate_All_Tasks_Sequential;"); 512 WBI (" pragma Import (C, Activate_All_Tasks_Sequential," & 513 " ""__gnat_activate_all_tasks"");"); 514 end if; 515 516 WBI (" begin"); 517 518 if Main_Priority /= No_Main_Priority then 519 Set_String (" Main_Priority := "); 520 Set_Int (Main_Priority); 521 Set_Char (';'); 522 Write_Statement_Buffer; 523 end if; 524 525 if Main_CPU /= No_Main_CPU then 526 Set_String (" Main_CPU := "); 527 Set_Int (Main_CPU); 528 Set_Char (';'); 529 Write_Statement_Buffer; 530 end if; 531 532 if System_Tasking_Restricted_Stages_Used 533 and then Partition_Elaboration_Policy_Specified = 'S' 534 then 535 Set_String (" Partition_Elaboration_Policy := '"); 536 Set_Char (Partition_Elaboration_Policy_Specified); 537 Set_String ("';"); 538 Write_Statement_Buffer; 539 end if; 540 541 if Main_Priority = No_Main_Priority 542 and then Main_CPU = No_Main_CPU 543 and then not System_Tasking_Restricted_Stages_Used 544 then 545 WBI (" null;"); 546 end if; 547 548 -- Normal case (standard library not suppressed). Set all global values 549 -- used by the run time. 550 551 else 552 WBI (" Main_Priority : Integer;"); 553 WBI (" pragma Import (C, Main_Priority, " & 554 """__gl_main_priority"");"); 555 WBI (" Time_Slice_Value : Integer;"); 556 WBI (" pragma Import (C, Time_Slice_Value, " & 557 """__gl_time_slice_val"");"); 558 WBI (" WC_Encoding : Character;"); 559 WBI (" pragma Import (C, WC_Encoding, ""__gl_wc_encoding"");"); 560 WBI (" Locking_Policy : Character;"); 561 WBI (" pragma Import (C, Locking_Policy, " & 562 """__gl_locking_policy"");"); 563 WBI (" Queuing_Policy : Character;"); 564 WBI (" pragma Import (C, Queuing_Policy, " & 565 """__gl_queuing_policy"");"); 566 WBI (" Task_Dispatching_Policy : Character;"); 567 WBI (" pragma Import (C, Task_Dispatching_Policy, " & 568 """__gl_task_dispatching_policy"");"); 569 WBI (" Priority_Specific_Dispatching : System.Address;"); 570 WBI (" pragma Import (C, Priority_Specific_Dispatching, " & 571 """__gl_priority_specific_dispatching"");"); 572 WBI (" Num_Specific_Dispatching : Integer;"); 573 WBI (" pragma Import (C, Num_Specific_Dispatching, " & 574 """__gl_num_specific_dispatching"");"); 575 WBI (" Main_CPU : Integer;"); 576 WBI (" pragma Import (C, Main_CPU, " & 577 """__gl_main_cpu"");"); 578 579 WBI (" Interrupt_States : System.Address;"); 580 WBI (" pragma Import (C, Interrupt_States, " & 581 """__gl_interrupt_states"");"); 582 WBI (" Num_Interrupt_States : Integer;"); 583 WBI (" pragma Import (C, Num_Interrupt_States, " & 584 """__gl_num_interrupt_states"");"); 585 WBI (" Unreserve_All_Interrupts : Integer;"); 586 WBI (" pragma Import (C, Unreserve_All_Interrupts, " & 587 """__gl_unreserve_all_interrupts"");"); 588 589 if Exception_Tracebacks then 590 WBI (" Exception_Tracebacks : Integer;"); 591 WBI (" pragma Import (C, Exception_Tracebacks, " & 592 """__gl_exception_tracebacks"");"); 593 end if; 594 595 WBI (" Detect_Blocking : Integer;"); 596 WBI (" pragma Import (C, Detect_Blocking, " & 597 """__gl_detect_blocking"");"); 598 WBI (" Default_Stack_Size : Integer;"); 599 WBI (" pragma Import (C, Default_Stack_Size, " & 600 """__gl_default_stack_size"");"); 601 WBI (" Leap_Seconds_Support : Integer;"); 602 WBI (" pragma Import (C, Leap_Seconds_Support, " & 603 """__gl_leap_seconds_support"");"); 604 605 -- Import entry point for elaboration time signal handler 606 -- installation, and indication of if it's been called previously. 607 608 WBI (""); 609 WBI (" procedure Runtime_Initialize " & 610 "(Install_Handler : Integer);"); 611 WBI (" pragma Import (C, Runtime_Initialize, " & 612 """__gnat_runtime_initialize"");"); 613 614 -- Import handlers attach procedure for sequential elaboration policy 615 616 if System_Interrupts_Used 617 and then Partition_Elaboration_Policy_Specified = 'S' 618 then 619 WBI (" procedure Install_Restricted_Handlers_Sequential;"); 620 WBI (" pragma Import (C," & 621 "Install_Restricted_Handlers_Sequential," & 622 " ""__gnat_attach_all_handlers"");"); 623 WBI (""); 624 end if; 625 626 -- Import task activation procedure for sequential elaboration 627 -- policy. 628 629 if System_Tasking_Restricted_Stages_Used 630 and then Partition_Elaboration_Policy_Specified = 'S' 631 then 632 WBI (" Partition_Elaboration_Policy : Character;"); 633 WBI (" pragma Import (C, Partition_Elaboration_Policy," & 634 " ""__gnat_partition_elaboration_policy"");"); 635 WBI (""); 636 WBI (" procedure Activate_All_Tasks_Sequential;"); 637 WBI (" pragma Import (C, Activate_All_Tasks_Sequential," & 638 " ""__gnat_activate_all_tasks"");"); 639 end if; 640 641 -- The import of the soft link which performs library-level object 642 -- finalization is not needed for VM targets; regular Ada is used in 643 -- that case. For restricted run-time libraries (ZFP and Ravenscar) 644 -- tasks are non-terminating, so we do not want finalization. 645 646 if VM_Target = No_VM and then not Configurable_Run_Time_On_Target then 647 WBI (""); 648 WBI (" Finalize_Library_Objects : No_Param_Proc;"); 649 WBI (" pragma Import (C, Finalize_Library_Objects, " & 650 """__gnat_finalize_library_objects"");"); 651 end if; 652 653 -- Initialize stack limit variable of the environment task if the 654 -- stack check method is stack limit and stack check is enabled. 655 656 if Stack_Check_Limits_On_Target 657 and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set) 658 then 659 WBI (""); 660 WBI (" procedure Initialize_Stack_Limit;"); 661 WBI (" pragma Import (C, Initialize_Stack_Limit, " & 662 """__gnat_initialize_stack_limit"");"); 663 end if; 664 665 -- Special processing when main program is CIL function/procedure 666 667 if VM_Target = CLI_Target 668 and then Bind_Main_Program 669 and then not No_Main_Subprogram 670 then 671 WBI (""); 672 673 -- Function case, use Set_Exit_Status to report the returned 674 -- status code, since that is the only mechanism available. 675 676 if ALIs.Table (ALIs.First).Main_Program = Func then 677 WBI (" Result : Integer;"); 678 WBI (" procedure Set_Exit_Status (Code : Integer);"); 679 WBI (" pragma Import (C, Set_Exit_Status, " & 680 """__gnat_set_exit_status"");"); 681 WBI (""); 682 WBI (" function Ada_Main_Program return Integer;"); 683 684 -- Procedure case 685 686 else 687 WBI (" procedure Ada_Main_Program;"); 688 end if; 689 690 Get_Name_String (Units.Table (First_Unit_Entry).Uname); 691 Name_Len := Name_Len - 2; 692 WBI (" pragma Import (CIL, Ada_Main_Program, """ 693 & Name_Buffer (1 .. Name_Len) & "." 694 & Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len)) & """);"); 695 end if; 696 697 -- When dispatching domains are used then we need to signal it 698 -- before calling the main procedure. 699 700 if Dispatching_Domains_Used then 701 WBI (" procedure Freeze_Dispatching_Domains;"); 702 WBI (" pragma Import"); 703 WBI (" (Ada, Freeze_Dispatching_Domains, " 704 & """__gnat_freeze_dispatching_domains"");"); 705 end if; 706 707 WBI (" begin"); 708 WBI (" if Is_Elaborated then"); 709 WBI (" return;"); 710 WBI (" end if;"); 711 WBI (" Is_Elaborated := True;"); 712 713 -- Call System.Elaboration_Allocators.Mark_Start_Of_Elaboration if 714 -- restriction No_Standard_Allocators_After_Elaboration is active. 715 716 if Cumulative_Restrictions.Set 717 (No_Standard_Allocators_After_Elaboration) 718 then 719 WBI (" System.Elaboration_Allocators." 720 & "Mark_Start_Of_Elaboration;"); 721 end if; 722 723 -- Generate assignments to initialize globals 724 725 Set_String (" Main_Priority := "); 726 Set_Int (Main_Priority); 727 Set_Char (';'); 728 Write_Statement_Buffer; 729 730 Set_String (" Time_Slice_Value := "); 731 732 if Task_Dispatching_Policy_Specified = 'F' 733 and then ALIs.Table (ALIs.First).Time_Slice_Value = -1 734 then 735 Set_Int (0); 736 else 737 Set_Int (ALIs.Table (ALIs.First).Time_Slice_Value); 738 end if; 739 740 Set_Char (';'); 741 Write_Statement_Buffer; 742 743 Set_String (" WC_Encoding := '"); 744 Set_Char (Get_WC_Encoding); 745 746 Set_String ("';"); 747 Write_Statement_Buffer; 748 749 Set_String (" Locking_Policy := '"); 750 Set_Char (Locking_Policy_Specified); 751 Set_String ("';"); 752 Write_Statement_Buffer; 753 754 Set_String (" Queuing_Policy := '"); 755 Set_Char (Queuing_Policy_Specified); 756 Set_String ("';"); 757 Write_Statement_Buffer; 758 759 Set_String (" Task_Dispatching_Policy := '"); 760 Set_Char (Task_Dispatching_Policy_Specified); 761 Set_String ("';"); 762 Write_Statement_Buffer; 763 764 if System_Tasking_Restricted_Stages_Used 765 and then Partition_Elaboration_Policy_Specified = 'S' 766 then 767 Set_String (" Partition_Elaboration_Policy := '"); 768 Set_Char (Partition_Elaboration_Policy_Specified); 769 Set_String ("';"); 770 Write_Statement_Buffer; 771 end if; 772 773 Gen_Restrictions; 774 775 WBI (" Priority_Specific_Dispatching :="); 776 WBI (" Local_Priority_Specific_Dispatching'Address;"); 777 778 Set_String (" Num_Specific_Dispatching := "); 779 Set_Int (PSD_Pragma_Settings.Last + 1); 780 Set_Char (';'); 781 Write_Statement_Buffer; 782 783 Set_String (" Main_CPU := "); 784 Set_Int (Main_CPU); 785 Set_Char (';'); 786 Write_Statement_Buffer; 787 788 WBI (" Interrupt_States := Local_Interrupt_States'Address;"); 789 790 Set_String (" Num_Interrupt_States := "); 791 Set_Int (IS_Pragma_Settings.Last + 1); 792 Set_Char (';'); 793 Write_Statement_Buffer; 794 795 Set_String (" Unreserve_All_Interrupts := "); 796 797 if Unreserve_All_Interrupts_Specified then 798 Set_String ("1"); 799 else 800 Set_String ("0"); 801 end if; 802 803 Set_Char (';'); 804 Write_Statement_Buffer; 805 806 if Exception_Tracebacks then 807 WBI (" Exception_Tracebacks := 1;"); 808 end if; 809 810 Set_String (" Detect_Blocking := "); 811 812 if Detect_Blocking then 813 Set_Int (1); 814 else 815 Set_Int (0); 816 end if; 817 818 Set_String (";"); 819 Write_Statement_Buffer; 820 821 Set_String (" Default_Stack_Size := "); 822 Set_Int (Default_Stack_Size); 823 Set_String (";"); 824 Write_Statement_Buffer; 825 826 Set_String (" Leap_Seconds_Support := "); 827 828 if Leap_Seconds_Support then 829 Set_Int (1); 830 else 831 Set_Int (0); 832 end if; 833 834 Set_String (";"); 835 Write_Statement_Buffer; 836 837 -- Generate call to Install_Handler 838 839 -- In .NET, when binding with -z, we don't install the signal handler 840 -- to let the caller handle the last exception handler. 841 842 WBI (""); 843 844 if VM_Target /= CLI_Target 845 or else Bind_Main_Program 846 then 847 WBI (" Runtime_Initialize (1);"); 848 else 849 WBI (" Runtime_Initialize (0);"); 850 end if; 851 end if; 852 853 -- Generate call to set Initialize_Scalar values if active 854 855 if Initialize_Scalars_Used then 856 WBI (""); 857 Set_String (" System.Scalar_Values.Initialize ('"); 858 Set_Char (Initialize_Scalars_Mode1); 859 Set_String ("', '"); 860 Set_Char (Initialize_Scalars_Mode2); 861 Set_String ("');"); 862 Write_Statement_Buffer; 863 end if; 864 865 -- Generate assignment of default secondary stack size if set 866 867 if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then 868 WBI (""); 869 Set_String (" System.Secondary_Stack."); 870 Set_String ("Default_Secondary_Stack_Size := "); 871 Set_Int (Opt.Default_Sec_Stack_Size); 872 Set_Char (';'); 873 Write_Statement_Buffer; 874 end if; 875 876 -- Initialize stack limit variable of the environment task if the 877 -- stack check method is stack limit and stack check is enabled. 878 879 if Stack_Check_Limits_On_Target 880 and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set) 881 then 882 WBI (""); 883 WBI (" Initialize_Stack_Limit;"); 884 end if; 885 886 -- On CodePeer, the finalization of library objects is not relevant 887 888 if CodePeer_Mode then 889 null; 890 891 -- On virtual machine targets, or on non-virtual machine ones if this 892 -- is the main program case, attach finalize_library to the soft link. 893 -- Do it only when not using a restricted run time, in which case tasks 894 -- are non-terminating, so we do not want library-level finalization. 895 896 elsif (VM_Target /= No_VM or else Bind_Main_Program) 897 and then not Configurable_Run_Time_On_Target 898 and then not Suppress_Standard_Library_On_Target 899 then 900 WBI (""); 901 902 if VM_Target = No_VM then 903 if Lib_Final_Built then 904 Set_String (" Finalize_Library_Objects := "); 905 Set_String ("finalize_library'access;"); 906 else 907 Set_String (" Finalize_Library_Objects := null;"); 908 end if; 909 910 -- On VM targets use regular Ada to set the soft link 911 912 else 913 if Lib_Final_Built then 914 Set_String 915 (" System.Soft_Links.Finalize_Library_Objects"); 916 Set_String (" := finalize_library'access;"); 917 else 918 Set_String 919 (" System.Soft_Links.Finalize_Library_Objects"); 920 Set_String (" := null;"); 921 end if; 922 end if; 923 924 Write_Statement_Buffer; 925 end if; 926 927 -- Generate elaboration calls 928 929 if not CodePeer_Mode then 930 WBI (""); 931 end if; 932 933 Gen_Elab_Calls; 934 935 -- Call System.Elaboration_Allocators.Mark_Start_Of_Elaboration if 936 -- restriction No_Standard_Allocators_After_Elaboration is active. 937 938 if Cumulative_Restrictions.Set 939 (No_Standard_Allocators_After_Elaboration) 940 then 941 WBI (" System.Elaboration_Allocators.Mark_End_Of_Elaboration;"); 942 end if; 943 944 -- From this point, no new dispatching domain can be created 945 946 if Dispatching_Domains_Used then 947 WBI (" Freeze_Dispatching_Domains;"); 948 end if; 949 950 -- Sequential partition elaboration policy 951 952 if Partition_Elaboration_Policy_Specified = 'S' then 953 if System_Interrupts_Used then 954 WBI (" Install_Restricted_Handlers_Sequential;"); 955 end if; 956 957 if System_Tasking_Restricted_Stages_Used then 958 WBI (" Activate_All_Tasks_Sequential;"); 959 end if; 960 end if; 961 962 -- Case of main program is CIL function or procedure 963 964 if VM_Target = CLI_Target 965 and then Bind_Main_Program 966 and then not No_Main_Subprogram 967 then 968 -- For function case, use Set_Exit_Status to set result 969 970 if ALIs.Table (ALIs.First).Main_Program = Func then 971 WBI (" Result := Ada_Main_Program;"); 972 WBI (" Set_Exit_Status (Result);"); 973 974 -- Procedure case 975 976 else 977 WBI (" Ada_Main_Program;"); 978 end if; 979 end if; 980 981 WBI (" end " & Ada_Init_Name.all & ";"); 982 WBI (""); 983 end Gen_Adainit; 984 985 -------------------------- 986 -- Gen_CodePeer_Wrapper -- 987 -------------------------- 988 989 procedure Gen_CodePeer_Wrapper is 990 Callee_Name : constant String := "Ada_Main_Program"; 991 992 begin 993 if ALIs.Table (ALIs.First).Main_Program = Proc then 994 WBI (" procedure " & CodePeer_Wrapper_Name & " is "); 995 WBI (" begin"); 996 WBI (" " & Callee_Name & ";"); 997 998 else 999 WBI (" function " & CodePeer_Wrapper_Name & " return Integer is"); 1000 WBI (" begin"); 1001 WBI (" return " & Callee_Name & ";"); 1002 end if; 1003 1004 WBI (" end " & CodePeer_Wrapper_Name & ";"); 1005 WBI (""); 1006 end Gen_CodePeer_Wrapper; 1007 1008 -------------------- 1009 -- Gen_Elab_Calls -- 1010 -------------------- 1011 1012 procedure Gen_Elab_Calls is 1013 Check_Elab_Flag : Boolean; 1014 1015 begin 1016 -- Loop through elaboration order entries 1017 1018 for E in Elab_Order.First .. Elab_Order.Last loop 1019 declare 1020 Unum : constant Unit_Id := Elab_Order.Table (E); 1021 U : Unit_Record renames Units.Table (Unum); 1022 1023 Unum_Spec : Unit_Id; 1024 -- This is the unit number of the spec that corresponds to 1025 -- this entry. It is the same as Unum except when the body 1026 -- and spec are different and we are currently processing 1027 -- the body, in which case it is the spec (Unum + 1). 1028 1029 begin 1030 if U.Utype = Is_Body then 1031 Unum_Spec := Unum + 1; 1032 else 1033 Unum_Spec := Unum; 1034 end if; 1035 1036 -- Nothing to do if predefined unit in no run time mode 1037 1038 if No_Run_Time_Mode and then Is_Predefined_File_Name (U.Sfile) then 1039 null; 1040 1041 -- Likewise if this is an interface to a stand alone library 1042 1043 elsif U.SAL_Interface then 1044 null; 1045 1046 -- Case of no elaboration code 1047 1048 elsif U.No_Elab 1049 1050 -- In CodePeer mode, we special case subprogram bodies which 1051 -- are handled in the 'else' part below, and lead to a call 1052 -- to <subp>'Elab_Subp_Body. 1053 1054 and then (not CodePeer_Mode 1055 1056 -- Test for spec 1057 1058 or else U.Utype = Is_Spec 1059 or else U.Utype = Is_Spec_Only 1060 or else U.Unit_Kind /= 's') 1061 then 1062 -- In the case of a body with a separate spec, where the 1063 -- separate spec has an elaboration entity defined, this is 1064 -- where we increment the elaboration entity if one exists 1065 1066 if U.Utype = Is_Body 1067 and then Units.Table (Unum_Spec).Set_Elab_Entity 1068 and then not CodePeer_Mode 1069 then 1070 Set_String (" E"); 1071 Set_Unit_Number (Unum_Spec); 1072 1073 -- The AAMP target has no notion of shared libraries, and 1074 -- there's no possibility of reelaboration, so we treat the 1075 -- the elaboration var as a flag instead of a counter and 1076 -- simply set it. 1077 1078 if AAMP_On_Target then 1079 Set_String (" := 1;"); 1080 1081 -- Otherwise (normal case), increment elaboration counter 1082 1083 else 1084 Set_String (" := E"); 1085 Set_Unit_Number (Unum_Spec); 1086 Set_String (" + 1;"); 1087 end if; 1088 1089 Write_Statement_Buffer; 1090 1091 -- In the special case where the target is AAMP and the unit is 1092 -- a spec with a body, the elaboration entity is initialized 1093 -- here. This is done because it's the only way to accomplish 1094 -- initialization of such entities, as there is no mechanism 1095 -- for load time global variable initialization on AAMP. 1096 1097 elsif AAMP_On_Target 1098 and then U.Utype = Is_Spec 1099 and then Units.Table (Unum_Spec).Set_Elab_Entity 1100 then 1101 Set_String (" E"); 1102 Set_Unit_Number (Unum_Spec); 1103 Set_String (" := 0;"); 1104 Write_Statement_Buffer; 1105 end if; 1106 1107 -- Here if elaboration code is present. If binding a library 1108 -- or if there is a non-Ada main subprogram then we generate: 1109 1110 -- if uname_E = 0 then 1111 -- uname'elab_[spec|body]; 1112 -- end if; 1113 -- uname_E := uname_E + 1; 1114 1115 -- Otherwise, elaboration routines are called unconditionally: 1116 1117 -- uname'elab_[spec|body]; 1118 -- uname_E := uname_E + 1; 1119 1120 -- The uname_E increment is skipped if this is a separate spec, 1121 -- since it will be done when we process the body. 1122 1123 -- In CodePeer mode, we do not generate any reference to xxx_E 1124 -- variables, only calls to 'Elab* subprograms. 1125 1126 else 1127 -- In the special case where the target is AAMP and the unit is 1128 -- a spec with a body, the elaboration entity is initialized 1129 -- here. This is done because it's the only way to accomplish 1130 -- initialization of such entities, as there is no mechanism 1131 -- for load time global variable initialization on AAMP. 1132 1133 if AAMP_On_Target 1134 and then U.Utype = Is_Spec 1135 and then Units.Table (Unum_Spec).Set_Elab_Entity 1136 then 1137 Set_String (" E"); 1138 Set_Unit_Number (Unum_Spec); 1139 Set_String (" := 0;"); 1140 Write_Statement_Buffer; 1141 end if; 1142 1143 -- Check incompatibilities with No_Multiple_Elaboration 1144 1145 if not CodePeer_Mode 1146 and then Cumulative_Restrictions.Set (No_Multiple_Elaboration) 1147 then 1148 -- Force_Checking_Of_Elaboration_Flags (-F) not allowed 1149 1150 if Force_Checking_Of_Elaboration_Flags then 1151 Osint.Fail 1152 ("-F (force elaboration checks) switch not allowed " 1153 & "with restriction No_Multiple_Elaboration active"); 1154 1155 -- Interfacing of libraries not allowed 1156 1157 elsif Interface_Library_Unit then 1158 Osint.Fail 1159 ("binding of interfaced libraries not allowed " 1160 & "with restriction No_Multiple_Elaboration active"); 1161 1162 -- Non-Ada main program not allowed 1163 1164 elsif not Bind_Main_Program then 1165 Osint.Fail 1166 ("non-Ada main program not allowed " 1167 & "with restriction No_Multiple_Elaboration active"); 1168 end if; 1169 end if; 1170 1171 -- OK, see if we need to test elaboration flag 1172 1173 Check_Elab_Flag := 1174 Units.Table (Unum_Spec).Set_Elab_Entity 1175 and then not CodePeer_Mode 1176 and then (Force_Checking_Of_Elaboration_Flags 1177 or Interface_Library_Unit 1178 or not Bind_Main_Program); 1179 1180 if Check_Elab_Flag then 1181 Set_String (" if E"); 1182 Set_Unit_Number (Unum_Spec); 1183 Set_String (" = 0 then"); 1184 Write_Statement_Buffer; 1185 Set_String (" "); 1186 end if; 1187 1188 Set_String (" "); 1189 Get_Decoded_Name_String_With_Brackets (U.Uname); 1190 1191 if VM_Target = CLI_Target and then U.Unit_Kind /= 's' then 1192 if Name_Buffer (Name_Len) = 's' then 1193 Name_Buffer (Name_Len - 1 .. Name_Len + 12) := 1194 "_pkg'elab_spec"; 1195 else 1196 Name_Buffer (Name_Len - 1 .. Name_Len + 12) := 1197 "_pkg'elab_body"; 1198 end if; 1199 1200 Name_Len := Name_Len + 12; 1201 1202 else 1203 if Name_Buffer (Name_Len) = 's' then 1204 Name_Buffer (Name_Len - 1 .. Name_Len + 8) := 1205 "'elab_spec"; 1206 Name_Len := Name_Len + 8; 1207 1208 -- Special case in CodePeer mode for subprogram bodies 1209 -- which correspond to CodePeer 'Elab_Subp_Body special 1210 -- init procedure. 1211 1212 elsif U.Unit_Kind = 's' and CodePeer_Mode then 1213 Name_Buffer (Name_Len - 1 .. Name_Len + 13) := 1214 "'elab_subp_body"; 1215 Name_Len := Name_Len + 13; 1216 1217 else 1218 Name_Buffer (Name_Len - 1 .. Name_Len + 8) := 1219 "'elab_body"; 1220 Name_Len := Name_Len + 8; 1221 end if; 1222 end if; 1223 1224 Set_Casing (U.Icasing); 1225 Set_Name_Buffer; 1226 Set_Char (';'); 1227 Write_Statement_Buffer; 1228 1229 if Check_Elab_Flag then 1230 WBI (" end if;"); 1231 end if; 1232 1233 if U.Utype /= Is_Spec 1234 and then not CodePeer_Mode 1235 and then Units.Table (Unum_Spec).Set_Elab_Entity 1236 then 1237 Set_String (" E"); 1238 Set_Unit_Number (Unum_Spec); 1239 1240 -- The AAMP target has no notion of shared libraries, and 1241 -- there's no possibility of reelaboration, so we treat the 1242 -- the elaboration var as a flag instead of a counter and 1243 -- simply set it. 1244 1245 if AAMP_On_Target then 1246 Set_String (" := 1;"); 1247 1248 -- Otherwise (normal case), increment elaboration counter 1249 1250 else 1251 Set_String (" := E"); 1252 Set_Unit_Number (Unum_Spec); 1253 Set_String (" + 1;"); 1254 end if; 1255 1256 Write_Statement_Buffer; 1257 end if; 1258 end if; 1259 end; 1260 end loop; 1261 end Gen_Elab_Calls; 1262 1263 ------------------------ 1264 -- Gen_Elab_Externals -- 1265 ------------------------ 1266 1267 procedure Gen_Elab_Externals is 1268 begin 1269 if CodePeer_Mode then 1270 return; 1271 end if; 1272 1273 for E in Elab_Order.First .. Elab_Order.Last loop 1274 declare 1275 Unum : constant Unit_Id := Elab_Order.Table (E); 1276 U : Unit_Record renames Units.Table (Unum); 1277 1278 begin 1279 -- Check for Elab_Entity to be set for this unit 1280 1281 if U.Set_Elab_Entity 1282 1283 -- Don't generate reference for stand alone library 1284 1285 and then not U.SAL_Interface 1286 1287 -- Don't generate reference for predefined file in No_Run_Time 1288 -- mode, since we don't include the object files in this case 1289 1290 and then not 1291 (No_Run_Time_Mode 1292 and then Is_Predefined_File_Name (U.Sfile)) 1293 then 1294 Set_String (" "); 1295 Set_String ("E"); 1296 Set_Unit_Number (Unum); 1297 1298 case VM_Target is 1299 when No_VM | JVM_Target => 1300 Set_String (" : Short_Integer; pragma Import (Ada, "); 1301 when CLI_Target => 1302 Set_String (" : Short_Integer; pragma Import (CIL, "); 1303 end case; 1304 1305 Set_String ("E"); 1306 Set_Unit_Number (Unum); 1307 Set_String (", """); 1308 Get_Name_String (U.Uname); 1309 1310 -- In the case of JGNAT we need to emit an Import name that 1311 -- includes the class name (using '$' separators in the case 1312 -- of a child unit name). 1313 1314 if VM_Target /= No_VM then 1315 for J in 1 .. Name_Len - 2 loop 1316 if VM_Target = CLI_Target 1317 or else Name_Buffer (J) /= '.' 1318 then 1319 Set_Char (Name_Buffer (J)); 1320 else 1321 Set_String ("$"); 1322 end if; 1323 end loop; 1324 1325 if VM_Target /= CLI_Target or else U.Unit_Kind = 's' then 1326 Set_String ("."); 1327 else 1328 Set_String ("_pkg."); 1329 end if; 1330 1331 -- If the unit name is very long, then split the 1332 -- Import link name across lines using "&" (occurs 1333 -- in some C2 tests). 1334 1335 if 2 * Name_Len + 60 > Hostparm.Max_Line_Length then 1336 Set_String (""" &"); 1337 Write_Statement_Buffer; 1338 Set_String (" """); 1339 end if; 1340 end if; 1341 1342 Set_Unit_Name; 1343 Set_String ("_E"");"); 1344 Write_Statement_Buffer; 1345 end if; 1346 end; 1347 end loop; 1348 1349 WBI (""); 1350 end Gen_Elab_Externals; 1351 1352 -------------------- 1353 -- Gen_Elab_Order -- 1354 -------------------- 1355 1356 procedure Gen_Elab_Order is 1357 begin 1358 WBI (" -- BEGIN ELABORATION ORDER"); 1359 1360 for J in Elab_Order.First .. Elab_Order.Last loop 1361 Set_String (" -- "); 1362 Get_Name_String (Units.Table (Elab_Order.Table (J)).Uname); 1363 Set_Name_Buffer; 1364 Write_Statement_Buffer; 1365 end loop; 1366 1367 WBI (" -- END ELABORATION ORDER"); 1368 WBI (""); 1369 end Gen_Elab_Order; 1370 1371 -------------------------- 1372 -- Gen_Finalize_Library -- 1373 -------------------------- 1374 1375 procedure Gen_Finalize_Library is 1376 Count : Int := 1; 1377 U : Unit_Record; 1378 Uspec : Unit_Record; 1379 Unum : Unit_Id; 1380 1381 procedure Gen_Header; 1382 -- Generate the header of the finalization routine 1383 1384 ---------------- 1385 -- Gen_Header -- 1386 ---------------- 1387 1388 procedure Gen_Header is 1389 begin 1390 WBI (" procedure finalize_library is"); 1391 WBI (" begin"); 1392 end Gen_Header; 1393 1394 -- Start of processing for Gen_Finalize_Library 1395 1396 begin 1397 if CodePeer_Mode then 1398 return; 1399 end if; 1400 1401 for E in reverse Elab_Order.First .. Elab_Order.Last loop 1402 Unum := Elab_Order.Table (E); 1403 U := Units.Table (Unum); 1404 1405 -- Dealing with package bodies is a little complicated. In such 1406 -- cases we must retrieve the package spec since it contains the 1407 -- spec of the body finalizer. 1408 1409 if U.Utype = Is_Body then 1410 Unum := Unum + 1; 1411 Uspec := Units.Table (Unum); 1412 else 1413 Uspec := U; 1414 end if; 1415 1416 Get_Name_String (Uspec.Uname); 1417 1418 -- We are only interested in non-generic packages 1419 1420 if U.Unit_Kind /= 'p' or else U.Is_Generic then 1421 null; 1422 1423 -- That aren't an interface to a stand alone library 1424 1425 elsif U.SAL_Interface then 1426 null; 1427 1428 -- Case of no finalization 1429 1430 elsif not U.Has_Finalizer then 1431 1432 -- The only case in which we have to do something is if this 1433 -- is a body, with a separate spec, where the separate spec 1434 -- has a finalizer. In that case, this is where we decrement 1435 -- the elaboration entity. 1436 1437 if U.Utype = Is_Body and then Uspec.Has_Finalizer then 1438 if not Lib_Final_Built then 1439 Gen_Header; 1440 Lib_Final_Built := True; 1441 end if; 1442 1443 Set_String (" E"); 1444 Set_Unit_Number (Unum); 1445 Set_String (" := E"); 1446 Set_Unit_Number (Unum); 1447 Set_String (" - 1;"); 1448 Write_Statement_Buffer; 1449 end if; 1450 1451 else 1452 if not Lib_Final_Built then 1453 Gen_Header; 1454 Lib_Final_Built := True; 1455 end if; 1456 1457 -- Generate: 1458 -- declare 1459 -- procedure F<Count>; 1460 1461 Set_String (" declare"); 1462 Write_Statement_Buffer; 1463 1464 Set_String (" procedure F"); 1465 Set_Int (Count); 1466 Set_Char (';'); 1467 Write_Statement_Buffer; 1468 1469 -- Generate: 1470 -- pragma Import (CIL, F<Count>, 1471 -- "xx.yy_pkg.xx__yy__finalize_[body|spec]"); 1472 -- -- for .NET targets 1473 1474 -- pragma Import (Java, F<Count>, 1475 -- "xx$yy.xx__yy__finalize_[body|spec]"); 1476 -- -- for JVM targets 1477 1478 -- pragma Import (Ada, F<Count>, 1479 -- "xx__yy__finalize_[body|spec]"); 1480 -- -- for default targets 1481 1482 if VM_Target = CLI_Target then 1483 Set_String (" pragma Import (CIL, F"); 1484 elsif VM_Target = JVM_Target then 1485 Set_String (" pragma Import (Java, F"); 1486 else 1487 Set_String (" pragma Import (Ada, F"); 1488 end if; 1489 1490 Set_Int (Count); 1491 Set_String (", """); 1492 1493 -- Perform name construction 1494 1495 -- .NET xx.yy_pkg.xx__yy__finalize 1496 1497 if VM_Target = CLI_Target then 1498 Set_Unit_Name (Mode => Dot); 1499 Set_String ("_pkg."); 1500 1501 -- JVM xx$yy.xx__yy__finalize 1502 1503 elsif VM_Target = JVM_Target then 1504 Set_Unit_Name (Mode => Dollar_Sign); 1505 Set_Char ('.'); 1506 end if; 1507 1508 -- Default xx__yy__finalize 1509 1510 Set_Unit_Name; 1511 Set_String ("__finalize_"); 1512 1513 -- Package spec processing 1514 1515 if U.Utype = Is_Spec 1516 or else U.Utype = Is_Spec_Only 1517 then 1518 Set_String ("spec"); 1519 1520 -- Package body processing 1521 1522 else 1523 Set_String ("body"); 1524 end if; 1525 1526 Set_String (""");"); 1527 Write_Statement_Buffer; 1528 1529 -- If binding a library or if there is a non-Ada main subprogram 1530 -- then we generate: 1531 1532 -- begin 1533 -- uname_E := uname_E - 1; 1534 -- if uname_E = 0 then 1535 -- F<Count>; 1536 -- end if; 1537 -- end; 1538 1539 -- Otherwise, finalization routines are called unconditionally: 1540 1541 -- begin 1542 -- uname_E := uname_E - 1; 1543 -- F<Count>; 1544 -- end; 1545 1546 -- The uname_E decrement is skipped if this is a separate spec, 1547 -- since it will be done when we process the body. 1548 1549 WBI (" begin"); 1550 1551 if U.Utype /= Is_Spec then 1552 Set_String (" E"); 1553 Set_Unit_Number (Unum); 1554 Set_String (" := E"); 1555 Set_Unit_Number (Unum); 1556 Set_String (" - 1;"); 1557 Write_Statement_Buffer; 1558 end if; 1559 1560 if Interface_Library_Unit or not Bind_Main_Program then 1561 Set_String (" if E"); 1562 Set_Unit_Number (Unum); 1563 Set_String (" = 0 then"); 1564 Write_Statement_Buffer; 1565 Set_String (" "); 1566 end if; 1567 1568 Set_String (" F"); 1569 Set_Int (Count); 1570 Set_Char (';'); 1571 Write_Statement_Buffer; 1572 1573 if Interface_Library_Unit or not Bind_Main_Program then 1574 WBI (" end if;"); 1575 end if; 1576 1577 WBI (" end;"); 1578 1579 Count := Count + 1; 1580 end if; 1581 end loop; 1582 1583 if Lib_Final_Built then 1584 1585 -- It is possible that the finalization of a library-level object 1586 -- raised an exception. In that case import the actual exception 1587 -- and the routine necessary to raise it. 1588 1589 if VM_Target = No_VM then 1590 WBI (" declare"); 1591 WBI (" procedure Reraise_Library_Exception_If_Any;"); 1592 1593 Set_String (" pragma Import (Ada, "); 1594 Set_String ("Reraise_Library_Exception_If_Any, "); 1595 Set_String ("""__gnat_reraise_library_exception_if_any"");"); 1596 Write_Statement_Buffer; 1597 1598 WBI (" begin"); 1599 WBI (" Reraise_Library_Exception_If_Any;"); 1600 WBI (" end;"); 1601 1602 -- VM-specific code, use regular Ada to produce the desired behavior 1603 1604 else 1605 WBI (" if System.Soft_Links.Library_Exception_Set then"); 1606 1607 Set_String (" Ada.Exceptions.Reraise_Occurrence ("); 1608 Set_String ("System.Soft_Links.Library_Exception);"); 1609 Write_Statement_Buffer; 1610 1611 WBI (" end if;"); 1612 end if; 1613 1614 WBI (" end finalize_library;"); 1615 WBI (""); 1616 end if; 1617 end Gen_Finalize_Library; 1618 1619 -------------- 1620 -- Gen_Main -- 1621 -------------- 1622 1623 procedure Gen_Main is 1624 begin 1625 if not No_Main_Subprogram then 1626 1627 -- To call the main program, we declare it using a pragma Import 1628 -- Ada with the right link name. 1629 1630 -- It might seem more obvious to "with" the main program, and call 1631 -- it in the normal Ada manner. We do not do this for three 1632 -- reasons: 1633 1634 -- 1. It is more efficient not to recompile the main program 1635 -- 2. We are not entitled to assume the source is accessible 1636 -- 3. We don't know what options to use to compile it 1637 1638 -- It is really reason 3 that is most critical (indeed we used 1639 -- to generate the "with", but several regression tests failed). 1640 1641 if ALIs.Table (ALIs.First).Main_Program = Func then 1642 WBI (" function Ada_Main_Program return Integer;"); 1643 else 1644 WBI (" procedure Ada_Main_Program;"); 1645 end if; 1646 1647 Set_String (" pragma Import (Ada, Ada_Main_Program, """); 1648 Get_Name_String (Units.Table (First_Unit_Entry).Uname); 1649 Set_Main_Program_Name; 1650 Set_String (""");"); 1651 1652 Write_Statement_Buffer; 1653 WBI (""); 1654 1655 -- For CodePeer, declare a wrapper for the user-defined main program 1656 1657 if CodePeer_Mode then 1658 Gen_CodePeer_Wrapper; 1659 end if; 1660 end if; 1661 1662 if Exit_Status_Supported_On_Target then 1663 Set_String (" function "); 1664 else 1665 Set_String (" procedure "); 1666 end if; 1667 1668 Set_String (Get_Main_Name); 1669 1670 if Command_Line_Args_On_Target then 1671 Write_Statement_Buffer; 1672 WBI (" (argc : Integer;"); 1673 WBI (" argv : System.Address;"); 1674 WBI (" envp : System.Address)"); 1675 1676 if Exit_Status_Supported_On_Target then 1677 WBI (" return Integer"); 1678 end if; 1679 1680 WBI (" is"); 1681 1682 else 1683 if Exit_Status_Supported_On_Target then 1684 Set_String (" return Integer is"); 1685 else 1686 Set_String (" is"); 1687 end if; 1688 1689 Write_Statement_Buffer; 1690 end if; 1691 1692 if Opt.Default_Exit_Status /= 0 1693 and then Bind_Main_Program 1694 and then not Configurable_Run_Time_Mode 1695 then 1696 WBI (" procedure Set_Exit_Status (Status : Integer);"); 1697 WBI (" pragma Import (C, Set_Exit_Status, " & 1698 """__gnat_set_exit_status"");"); 1699 WBI (""); 1700 end if; 1701 1702 -- Initialize and Finalize 1703 1704 if not CodePeer_Mode 1705 and then not Cumulative_Restrictions.Set (No_Finalization) 1706 then 1707 WBI (" procedure Initialize (Addr : System.Address);"); 1708 WBI (" pragma Import (C, Initialize, ""__gnat_initialize"");"); 1709 WBI (""); 1710 WBI (" procedure Finalize;"); 1711 WBI (" pragma Import (C, Finalize, ""__gnat_finalize"");"); 1712 end if; 1713 1714 -- If we want to analyze the stack, we must import corresponding symbols 1715 1716 if Dynamic_Stack_Measurement then 1717 WBI (""); 1718 WBI (" procedure Output_Results;"); 1719 WBI (" pragma Import (C, Output_Results, " & 1720 """__gnat_stack_usage_output_results"");"); 1721 1722 WBI (""); 1723 WBI (" " & 1724 "procedure Initialize_Stack_Analysis (Buffer_Size : Natural);"); 1725 WBI (" pragma Import (C, Initialize_Stack_Analysis, " & 1726 """__gnat_stack_usage_initialize"");"); 1727 end if; 1728 1729 -- Deal with declarations for main program case 1730 1731 if not No_Main_Subprogram then 1732 if ALIs.Table (ALIs.First).Main_Program = Func then 1733 WBI (" Result : Integer;"); 1734 WBI (""); 1735 end if; 1736 1737 if Bind_Main_Program 1738 and not Suppress_Standard_Library_On_Target 1739 and not CodePeer_Mode 1740 then 1741 WBI (" SEH : aliased array (1 .. 2) of Integer;"); 1742 WBI (""); 1743 end if; 1744 end if; 1745 1746 -- Generate a reference to Ada_Main_Program_Name. This symbol is 1747 -- not referenced elsewhere in the generated program, but is needed 1748 -- by the debugger (that's why it is generated in the first place). 1749 -- The reference stops Ada_Main_Program_Name from being optimized 1750 -- away by smart linkers, such as the AiX linker. 1751 1752 -- Because this variable is unused, we make this variable "aliased" 1753 -- with a pragma Volatile in order to tell the compiler to preserve 1754 -- this variable at any level of optimization. 1755 1756 if Bind_Main_Program and not CodePeer_Mode then 1757 WBI (" Ensure_Reference : aliased System.Address := " & 1758 "Ada_Main_Program_Name'Address;"); 1759 WBI (" pragma Volatile (Ensure_Reference);"); 1760 WBI (""); 1761 end if; 1762 1763 WBI (" begin"); 1764 1765 -- Acquire command line arguments if present on target 1766 1767 if CodePeer_Mode then 1768 null; 1769 1770 elsif Command_Line_Args_On_Target then 1771 WBI (" gnat_argc := argc;"); 1772 WBI (" gnat_argv := argv;"); 1773 WBI (" gnat_envp := envp;"); 1774 WBI (""); 1775 1776 -- If configurable run time and no command line args, then nothing 1777 -- needs to be done since the gnat_argc/argv/envp variables are 1778 -- suppressed in this case. 1779 1780 elsif Configurable_Run_Time_On_Target then 1781 null; 1782 1783 -- Otherwise set dummy values (to be filled in by some other unit?) 1784 1785 else 1786 WBI (" gnat_argc := 0;"); 1787 WBI (" gnat_argv := System.Null_Address;"); 1788 WBI (" gnat_envp := System.Null_Address;"); 1789 end if; 1790 1791 if Opt.Default_Exit_Status /= 0 1792 and then Bind_Main_Program 1793 and then not Configurable_Run_Time_Mode 1794 then 1795 Set_String (" Set_Exit_Status ("); 1796 Set_Int (Opt.Default_Exit_Status); 1797 Set_String (");"); 1798 Write_Statement_Buffer; 1799 end if; 1800 1801 if Dynamic_Stack_Measurement then 1802 Set_String (" Initialize_Stack_Analysis ("); 1803 Set_Int (Dynamic_Stack_Measurement_Array_Size); 1804 Set_String (");"); 1805 Write_Statement_Buffer; 1806 end if; 1807 1808 if not Cumulative_Restrictions.Set (No_Finalization) 1809 and then not CodePeer_Mode 1810 then 1811 if not No_Main_Subprogram 1812 and then Bind_Main_Program 1813 and then not Suppress_Standard_Library_On_Target 1814 then 1815 WBI (" Initialize (SEH'Address);"); 1816 else 1817 WBI (" Initialize (System.Null_Address);"); 1818 end if; 1819 end if; 1820 1821 WBI (" " & Ada_Init_Name.all & ";"); 1822 1823 if not No_Main_Subprogram then 1824 if CodePeer_Mode then 1825 if ALIs.Table (ALIs.First).Main_Program = Proc then 1826 WBI (" " & CodePeer_Wrapper_Name & ";"); 1827 else 1828 WBI (" Result := " & CodePeer_Wrapper_Name & ";"); 1829 end if; 1830 1831 elsif ALIs.Table (ALIs.First).Main_Program = Proc then 1832 WBI (" Ada_Main_Program;"); 1833 1834 else 1835 WBI (" Result := Ada_Main_Program;"); 1836 end if; 1837 end if; 1838 1839 -- Adafinal call is skipped if no finalization 1840 1841 if not Cumulative_Restrictions.Set (No_Finalization) then 1842 WBI (" adafinal;"); 1843 end if; 1844 1845 -- Prints the result of static stack analysis 1846 1847 if Dynamic_Stack_Measurement then 1848 WBI (" Output_Results;"); 1849 end if; 1850 1851 -- Finalize is only called if we have a run time 1852 1853 if not Cumulative_Restrictions.Set (No_Finalization) 1854 and then not CodePeer_Mode 1855 then 1856 WBI (" Finalize;"); 1857 end if; 1858 1859 -- Return result 1860 1861 if Exit_Status_Supported_On_Target then 1862 if No_Main_Subprogram 1863 or else ALIs.Table (ALIs.First).Main_Program = Proc 1864 then 1865 WBI (" return (gnat_exit_status);"); 1866 else 1867 WBI (" return (Result);"); 1868 end if; 1869 end if; 1870 1871 WBI (" end;"); 1872 WBI (""); 1873 end Gen_Main; 1874 1875 ------------------------------ 1876 -- Gen_Object_Files_Options -- 1877 ------------------------------ 1878 1879 procedure Gen_Object_Files_Options is 1880 Lgnat : Natural; 1881 -- This keeps track of the position in the sorted set of entries 1882 -- in the Linker_Options table of where the first entry from an 1883 -- internal file appears. 1884 1885 Linker_Option_List_Started : Boolean := False; 1886 -- Set to True when "LINKER OPTION LIST" is displayed 1887 1888 procedure Write_Linker_Option; 1889 -- Write binder info linker option 1890 1891 ------------------------- 1892 -- Write_Linker_Option -- 1893 ------------------------- 1894 1895 procedure Write_Linker_Option is 1896 Start : Natural; 1897 Stop : Natural; 1898 1899 begin 1900 -- Loop through string, breaking at null's 1901 1902 Start := 1; 1903 while Start < Name_Len loop 1904 1905 -- Find null ending this section 1906 1907 Stop := Start + 1; 1908 while Name_Buffer (Stop) /= ASCII.NUL 1909 and then Stop <= Name_Len loop 1910 Stop := Stop + 1; 1911 end loop; 1912 1913 -- Process section if non-null 1914 1915 if Stop > Start then 1916 if Output_Linker_Option_List then 1917 if not Zero_Formatting then 1918 if not Linker_Option_List_Started then 1919 Linker_Option_List_Started := True; 1920 Write_Eol; 1921 Write_Str (" LINKER OPTION LIST"); 1922 Write_Eol; 1923 Write_Eol; 1924 end if; 1925 1926 Write_Str (" "); 1927 end if; 1928 1929 Write_Str (Name_Buffer (Start .. Stop - 1)); 1930 Write_Eol; 1931 end if; 1932 WBI (" -- " & Name_Buffer (Start .. Stop - 1)); 1933 end if; 1934 1935 Start := Stop + 1; 1936 end loop; 1937 end Write_Linker_Option; 1938 1939 -- Start of processing for Gen_Object_Files_Options 1940 1941 begin 1942 WBI ("-- BEGIN Object file/option list"); 1943 1944 if Object_List_Filename /= null then 1945 Set_List_File (Object_List_Filename.all); 1946 end if; 1947 1948 for E in Elab_Order.First .. Elab_Order.Last loop 1949 1950 -- If not spec that has an associated body, then generate a comment 1951 -- giving the name of the corresponding object file. 1952 1953 if not Units.Table (Elab_Order.Table (E)).SAL_Interface 1954 and then Units.Table (Elab_Order.Table (E)).Utype /= Is_Spec 1955 then 1956 Get_Name_String 1957 (ALIs.Table 1958 (Units.Table (Elab_Order.Table (E)).My_ALI).Ofile_Full_Name); 1959 1960 -- If the presence of an object file is necessary or if it exists, 1961 -- then use it. 1962 1963 if not Hostparm.Exclude_Missing_Objects 1964 or else 1965 System.OS_Lib.Is_Regular_File (Name_Buffer (1 .. Name_Len)) 1966 then 1967 WBI (" -- " & Name_Buffer (1 .. Name_Len)); 1968 1969 if Output_Object_List then 1970 Write_Str (Name_Buffer (1 .. Name_Len)); 1971 Write_Eol; 1972 end if; 1973 end if; 1974 end if; 1975 end loop; 1976 1977 if Object_List_Filename /= null then 1978 Close_List_File; 1979 end if; 1980 1981 -- Add a "-Ldir" for each directory in the object path 1982 1983 if VM_Target /= CLI_Target then 1984 for J in 1 .. Nb_Dir_In_Obj_Search_Path loop 1985 declare 1986 Dir : constant String_Ptr := Dir_In_Obj_Search_Path (J); 1987 begin 1988 Name_Len := 0; 1989 Add_Str_To_Name_Buffer ("-L"); 1990 Add_Str_To_Name_Buffer (Dir.all); 1991 Write_Linker_Option; 1992 end; 1993 end loop; 1994 end if; 1995 1996 if not (Opt.No_Run_Time_Mode or Opt.No_Stdlib) then 1997 Name_Len := 0; 1998 1999 if Opt.Shared_Libgnat then 2000 Add_Str_To_Name_Buffer ("-shared"); 2001 else 2002 Add_Str_To_Name_Buffer ("-static"); 2003 end if; 2004 2005 -- Write directly to avoid inclusion in -K output as -static and 2006 -- -shared are not usually specified linker options. 2007 2008 WBI (" -- " & Name_Buffer (1 .. Name_Len)); 2009 end if; 2010 2011 -- Sort linker options 2012 2013 -- This sort accomplishes two important purposes: 2014 2015 -- a) All application files are sorted to the front, and all GNAT 2016 -- internal files are sorted to the end. This results in a well 2017 -- defined dividing line between the two sets of files, for the 2018 -- purpose of inserting certain standard library references into 2019 -- the linker arguments list. 2020 2021 -- b) Given two different units, we sort the linker options so that 2022 -- those from a unit earlier in the elaboration order comes later 2023 -- in the list. This is a heuristic designed to create a more 2024 -- friendly order of linker options when the operations appear in 2025 -- separate units. The idea is that if unit A must be elaborated 2026 -- before unit B, then it is more likely that B references 2027 -- libraries included by A, than vice versa, so we want libraries 2028 -- included by A to come after libraries included by B. 2029 2030 -- These two criteria are implemented by function Lt_Linker_Option. Note 2031 -- that a special case of b) is that specs are elaborated before bodies, 2032 -- so linker options from specs come after linker options for bodies, 2033 -- and again, the assumption is that libraries used by the body are more 2034 -- likely to reference libraries used by the spec, than vice versa. 2035 2036 Sort 2037 (Linker_Options.Last, 2038 Move_Linker_Option'Access, 2039 Lt_Linker_Option'Access); 2040 2041 -- Write user linker options, i.e. the set of linker options that come 2042 -- from all files other than GNAT internal files, Lgnat is left set to 2043 -- point to the first entry from a GNAT internal file, or past the end 2044 -- of the entries if there are no internal files. 2045 2046 Lgnat := Linker_Options.Last + 1; 2047 2048 for J in 1 .. Linker_Options.Last loop 2049 if not Linker_Options.Table (J).Internal_File then 2050 Get_Name_String (Linker_Options.Table (J).Name); 2051 Write_Linker_Option; 2052 else 2053 Lgnat := J; 2054 exit; 2055 end if; 2056 end loop; 2057 2058 -- Now we insert standard linker options that must appear after the 2059 -- entries from user files, and before the entries from GNAT run-time 2060 -- files. The reason for this decision is that libraries referenced 2061 -- by internal routines may reference these standard library entries. 2062 2063 -- Note that we do not insert anything when pragma No_Run_Time has 2064 -- been specified or when the standard libraries are not to be used, 2065 -- otherwise on some platforms, we may get duplicate symbols when 2066 -- linking (not clear if this is still the case, but it is harmless). 2067 2068 if not (Opt.No_Run_Time_Mode or else Opt.No_Stdlib) then 2069 if With_GNARL then 2070 Name_Len := 0; 2071 2072 if Opt.Shared_Libgnat then 2073 Add_Str_To_Name_Buffer (Shared_Lib ("gnarl")); 2074 else 2075 Add_Str_To_Name_Buffer ("-lgnarl"); 2076 end if; 2077 2078 Write_Linker_Option; 2079 end if; 2080 2081 Name_Len := 0; 2082 2083 if Opt.Shared_Libgnat then 2084 Add_Str_To_Name_Buffer (Shared_Lib ("gnat")); 2085 else 2086 Add_Str_To_Name_Buffer ("-lgnat"); 2087 end if; 2088 2089 Write_Linker_Option; 2090 end if; 2091 2092 -- Write linker options from all internal files 2093 2094 for J in Lgnat .. Linker_Options.Last loop 2095 Get_Name_String (Linker_Options.Table (J).Name); 2096 Write_Linker_Option; 2097 end loop; 2098 2099 if Output_Linker_Option_List and then not Zero_Formatting then 2100 Write_Eol; 2101 end if; 2102 2103 WBI ("-- END Object file/option list "); 2104 end Gen_Object_Files_Options; 2105 2106 --------------------- 2107 -- Gen_Output_File -- 2108 --------------------- 2109 2110 procedure Gen_Output_File (Filename : String) is 2111 begin 2112 -- Acquire settings for Interrupt_State pragmas 2113 2114 Set_IS_Pragma_Table; 2115 2116 -- Acquire settings for Priority_Specific_Dispatching pragma 2117 2118 Set_PSD_Pragma_Table; 2119 2120 -- For JGNAT the main program is already generated by the compiler 2121 2122 if VM_Target = JVM_Target then 2123 Bind_Main_Program := False; 2124 end if; 2125 2126 -- Override time slice value if -T switch is set 2127 2128 if Time_Slice_Set then 2129 ALIs.Table (ALIs.First).Time_Slice_Value := Opt.Time_Slice_Value; 2130 end if; 2131 2132 -- Count number of elaboration calls 2133 2134 for E in Elab_Order.First .. Elab_Order.Last loop 2135 if Units.Table (Elab_Order.Table (E)).No_Elab then 2136 null; 2137 else 2138 Num_Elab_Calls := Num_Elab_Calls + 1; 2139 end if; 2140 end loop; 2141 2142 -- Generate output file in appropriate language 2143 2144 Gen_Output_File_Ada (Filename); 2145 end Gen_Output_File; 2146 2147 ------------------------- 2148 -- Gen_Output_File_Ada -- 2149 ------------------------- 2150 2151 procedure Gen_Output_File_Ada (Filename : String) is 2152 2153 Ada_Main : constant String := Get_Ada_Main_Name; 2154 -- Name to be used for generated Ada main program. See the body of 2155 -- function Get_Ada_Main_Name for details on the form of the name. 2156 2157 Needs_Library_Finalization : constant Boolean := 2158 not Configurable_Run_Time_On_Target and then Has_Finalizer; 2159 -- For restricted run-time libraries (ZFP and Ravenscar) tasks are 2160 -- non-terminating, so we do not want finalization. 2161 2162 Bfiles : Name_Id; 2163 -- Name of generated bind file (spec) 2164 2165 Bfileb : Name_Id; 2166 -- Name of generated bind file (body) 2167 2168 begin 2169 -- Create spec first 2170 2171 Create_Binder_Output (Filename, 's', Bfiles); 2172 2173 -- We always compile the binder file in Ada 95 mode so that we properly 2174 -- handle use of Ada 2005 keywords as identifiers in Ada 95 mode. None 2175 -- of the Ada 2005 or Ada 2012 constructs are needed by the binder file. 2176 2177 WBI ("pragma Ada_95;"); 2178 2179 -- If we are operating in Restrictions (No_Exception_Handlers) mode, 2180 -- then we need to make sure that the binder program is compiled with 2181 -- the same restriction, so that no exception tables are generated. 2182 2183 if Cumulative_Restrictions.Set (No_Exception_Handlers) then 2184 WBI ("pragma Restrictions (No_Exception_Handlers);"); 2185 end if; 2186 2187 -- Same processing for Restrictions (No_Exception_Propagation) 2188 2189 if Cumulative_Restrictions.Set (No_Exception_Propagation) then 2190 WBI ("pragma Restrictions (No_Exception_Propagation);"); 2191 end if; 2192 2193 -- Same processing for pragma No_Run_Time 2194 2195 if No_Run_Time_Mode then 2196 WBI ("pragma No_Run_Time;"); 2197 end if; 2198 2199 -- Generate with of System so we can reference System.Address 2200 2201 WBI ("with System;"); 2202 2203 -- Generate with of System.Initialize_Scalars if active 2204 2205 if Initialize_Scalars_Used then 2206 WBI ("with System.Scalar_Values;"); 2207 end if; 2208 2209 -- Generate with of System.Secondary_Stack if active 2210 2211 if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then 2212 WBI ("with System.Secondary_Stack;"); 2213 end if; 2214 2215 Resolve_Binder_Options; 2216 2217 -- Generate standard with's 2218 2219 if not Suppress_Standard_Library_On_Target then 2220 if CodePeer_Mode then 2221 WBI ("with System.Standard_Library;"); 2222 elsif VM_Target /= No_VM then 2223 WBI ("with System.Soft_Links;"); 2224 WBI ("with System.Standard_Library;"); 2225 end if; 2226 end if; 2227 2228 WBI ("package " & Ada_Main & " is"); 2229 WBI (" pragma Warnings (Off);"); 2230 2231 -- Main program case 2232 2233 if Bind_Main_Program then 2234 if VM_Target = No_VM then 2235 2236 -- Generate argc/argv stuff unless suppressed 2237 2238 if Command_Line_Args_On_Target 2239 or not Configurable_Run_Time_On_Target 2240 then 2241 WBI (""); 2242 WBI (" gnat_argc : Integer;"); 2243 WBI (" gnat_argv : System.Address;"); 2244 WBI (" gnat_envp : System.Address;"); 2245 2246 -- If the standard library is not suppressed, these variables 2247 -- are in the run-time data area for easy run time access. 2248 2249 if not Suppress_Standard_Library_On_Target then 2250 WBI (""); 2251 WBI (" pragma Import (C, gnat_argc);"); 2252 WBI (" pragma Import (C, gnat_argv);"); 2253 WBI (" pragma Import (C, gnat_envp);"); 2254 end if; 2255 end if; 2256 2257 -- Define exit status. Again in normal mode, this is in the 2258 -- run-time library, and is initialized there, but in the 2259 -- configurable runtime case, the variable is declared and 2260 -- initialized in this file. 2261 2262 WBI (""); 2263 2264 if Configurable_Run_Time_Mode then 2265 if Exit_Status_Supported_On_Target then 2266 WBI (" gnat_exit_status : Integer := 0;"); 2267 end if; 2268 2269 else 2270 WBI (" gnat_exit_status : Integer;"); 2271 WBI (" pragma Import (C, gnat_exit_status);"); 2272 end if; 2273 end if; 2274 2275 -- Generate the GNAT_Version and Ada_Main_Program_Name info only for 2276 -- the main program. Otherwise, it can lead under some circumstances 2277 -- to a symbol duplication during the link (for instance when a C 2278 -- program uses two Ada libraries). Also zero terminate the string 2279 -- so that its end can be found reliably at run time. 2280 2281 WBI (""); 2282 WBI (" GNAT_Version : constant String :="); 2283 WBI (" """ & Ver_Prefix & 2284 Gnat_Version_String & 2285 """ & ASCII.NUL;"); 2286 WBI (" pragma Export (C, GNAT_Version, ""__gnat_version"");"); 2287 2288 WBI (""); 2289 Set_String (" Ada_Main_Program_Name : constant String := """); 2290 Get_Name_String (Units.Table (First_Unit_Entry).Uname); 2291 2292 if VM_Target = No_VM then 2293 Set_Main_Program_Name; 2294 Set_String (""" & ASCII.NUL;"); 2295 else 2296 Set_String (Name_Buffer (1 .. Name_Len - 2) & """;"); 2297 end if; 2298 2299 Write_Statement_Buffer; 2300 2301 WBI 2302 (" pragma Export (C, Ada_Main_Program_Name, " & 2303 """__gnat_ada_main_program_name"");"); 2304 end if; 2305 2306 WBI (""); 2307 WBI (" procedure " & Ada_Init_Name.all & ";"); 2308 WBI (" pragma Export (C, " & Ada_Init_Name.all & ", """ & 2309 Ada_Init_Name.all & """);"); 2310 2311 -- If -a has been specified use pragma Linker_Constructor for the init 2312 -- procedure and pragma Linker_Destructor for the final procedure. 2313 2314 if Use_Pragma_Linker_Constructor then 2315 WBI (" pragma Linker_Constructor (" & Ada_Init_Name.all & ");"); 2316 end if; 2317 2318 if not Cumulative_Restrictions.Set (No_Finalization) then 2319 WBI (""); 2320 WBI (" procedure " & Ada_Final_Name.all & ";"); 2321 WBI (" pragma Export (C, " & Ada_Final_Name.all & ", """ & 2322 Ada_Final_Name.all & """);"); 2323 2324 if Use_Pragma_Linker_Constructor then 2325 WBI (" pragma Linker_Destructor (" & Ada_Final_Name.all & ");"); 2326 end if; 2327 end if; 2328 2329 if Bind_Main_Program and then VM_Target = No_VM then 2330 2331 WBI (""); 2332 2333 if Exit_Status_Supported_On_Target then 2334 Set_String (" function "); 2335 else 2336 Set_String (" procedure "); 2337 end if; 2338 2339 Set_String (Get_Main_Name); 2340 2341 -- Generate argument list if present 2342 2343 if Command_Line_Args_On_Target then 2344 Write_Statement_Buffer; 2345 WBI (" (argc : Integer;"); 2346 WBI (" argv : System.Address;"); 2347 Set_String 2348 (" envp : System.Address)"); 2349 2350 if Exit_Status_Supported_On_Target then 2351 Write_Statement_Buffer; 2352 WBI (" return Integer;"); 2353 else 2354 Write_Statement_Buffer (";"); 2355 end if; 2356 2357 else 2358 if Exit_Status_Supported_On_Target then 2359 Write_Statement_Buffer (" return Integer;"); 2360 else 2361 Write_Statement_Buffer (";"); 2362 end if; 2363 end if; 2364 2365 WBI (" pragma Export (C, " & Get_Main_Name & ", """ & 2366 Get_Main_Name & """);"); 2367 end if; 2368 2369 Gen_Versions; 2370 Gen_Elab_Order; 2371 2372 -- Spec is complete 2373 2374 WBI (""); 2375 WBI ("end " & Ada_Main & ";"); 2376 Close_Binder_Output; 2377 2378 -- Prepare to write body 2379 2380 Create_Binder_Output (Filename, 'b', Bfileb); 2381 2382 -- We always compile the binder file in Ada 95 mode so that we properly 2383 -- handle use of Ada 2005 keywords as identifiers in Ada 95 mode. None 2384 -- of the Ada 2005/2012 constructs are needed by the binder file. 2385 2386 WBI ("pragma Ada_95;"); 2387 2388 -- Output Source_File_Name pragmas which look like 2389 2390 -- pragma Source_File_Name (Ada_Main, Spec_File_Name => "sss"); 2391 -- pragma Source_File_Name (Ada_Main, Body_File_Name => "bbb"); 2392 2393 -- where sss/bbb are the spec/body file names respectively 2394 2395 Get_Name_String (Bfiles); 2396 Name_Buffer (Name_Len + 1 .. Name_Len + 3) := """);"; 2397 2398 WBI ("pragma Source_File_Name (" & 2399 Ada_Main & 2400 ", Spec_File_Name => """ & 2401 Name_Buffer (1 .. Name_Len + 3)); 2402 2403 Get_Name_String (Bfileb); 2404 Name_Buffer (Name_Len + 1 .. Name_Len + 3) := """);"; 2405 2406 WBI ("pragma Source_File_Name (" & 2407 Ada_Main & 2408 ", Body_File_Name => """ & 2409 Name_Buffer (1 .. Name_Len + 3)); 2410 2411 -- Generate pragma Suppress (Overflow_Check). This is needed for recent 2412 -- versions of the compiler which have overflow checks on by default. 2413 -- We do not want overflow checking enabled for the increments of the 2414 -- elaboration variables (since this can cause an unwanted reference to 2415 -- the last chance exception handler for limited run-times). 2416 2417 WBI ("pragma Suppress (Overflow_Check);"); 2418 2419 -- Generate with of System.Restrictions to initialize 2420 -- Run_Time_Restrictions. 2421 2422 if System_Restrictions_Used 2423 and not Suppress_Standard_Library_On_Target 2424 then 2425 WBI (""); 2426 WBI ("with System.Restrictions;"); 2427 end if; 2428 2429 -- Generate with of Ada.Exceptions if needs library finalization 2430 2431 if Needs_Library_Finalization then 2432 WBI ("with Ada.Exceptions;"); 2433 end if; 2434 2435 -- Generate with of System.Elaboration_Allocators if the restriction 2436 -- No_Standard_Allocators_After_Elaboration was present. 2437 2438 if Cumulative_Restrictions.Set 2439 (No_Standard_Allocators_After_Elaboration) 2440 then 2441 WBI ("with System.Elaboration_Allocators;"); 2442 end if; 2443 2444 -- Generate start of package body 2445 2446 WBI (""); 2447 WBI ("package body " & Ada_Main & " is"); 2448 WBI (" pragma Warnings (Off);"); 2449 WBI (""); 2450 2451 -- Generate externals for elaboration entities 2452 2453 Gen_Elab_Externals; 2454 2455 if not CodePeer_Mode then 2456 if not Suppress_Standard_Library_On_Target then 2457 2458 -- Generate Priority_Specific_Dispatching pragma string 2459 2460 Set_String 2461 (" Local_Priority_Specific_Dispatching : " & 2462 "constant String := """); 2463 2464 for J in 0 .. PSD_Pragma_Settings.Last loop 2465 Set_Char (PSD_Pragma_Settings.Table (J)); 2466 end loop; 2467 2468 Set_String (""";"); 2469 Write_Statement_Buffer; 2470 2471 -- Generate Interrupt_State pragma string 2472 2473 Set_String (" Local_Interrupt_States : constant String := """); 2474 2475 for J in 0 .. IS_Pragma_Settings.Last loop 2476 Set_Char (IS_Pragma_Settings.Table (J)); 2477 end loop; 2478 2479 Set_String (""";"); 2480 Write_Statement_Buffer; 2481 WBI (""); 2482 end if; 2483 2484 -- The B.1 (39) implementation advice says that the adainit/adafinal 2485 -- routines should be idempotent. Generate a flag to ensure that. 2486 -- This is not needed if we are suppressing the standard library 2487 -- since it would never be referenced. 2488 2489 if not Suppress_Standard_Library_On_Target then 2490 WBI (" Is_Elaborated : Boolean := False;"); 2491 end if; 2492 2493 WBI (""); 2494 end if; 2495 2496 -- Generate the adafinal routine unless there is no finalization to do 2497 2498 if not Cumulative_Restrictions.Set (No_Finalization) then 2499 if Needs_Library_Finalization then 2500 Gen_Finalize_Library; 2501 end if; 2502 2503 Gen_Adafinal; 2504 end if; 2505 2506 Gen_Adainit; 2507 2508 if Bind_Main_Program and then VM_Target = No_VM then 2509 Gen_Main; 2510 end if; 2511 2512 -- Output object file list and the Ada body is complete 2513 2514 Gen_Object_Files_Options; 2515 2516 WBI (""); 2517 WBI ("end " & Ada_Main & ";"); 2518 2519 Close_Binder_Output; 2520 end Gen_Output_File_Ada; 2521 2522 ---------------------- 2523 -- Gen_Restrictions -- 2524 ---------------------- 2525 2526 procedure Gen_Restrictions is 2527 Count : Integer; 2528 2529 begin 2530 if Suppress_Standard_Library_On_Target 2531 or not System_Restrictions_Used 2532 then 2533 return; 2534 end if; 2535 2536 WBI (" System.Restrictions.Run_Time_Restrictions :="); 2537 WBI (" (Set =>"); 2538 Set_String (" ("); 2539 2540 Count := 0; 2541 2542 for J in Cumulative_Restrictions.Set'Range loop 2543 Set_Boolean (Cumulative_Restrictions.Set (J)); 2544 Set_String (", "); 2545 Count := Count + 1; 2546 2547 if J /= Cumulative_Restrictions.Set'Last and then Count = 8 then 2548 Write_Statement_Buffer; 2549 Set_String (" "); 2550 Count := 0; 2551 end if; 2552 end loop; 2553 2554 Set_String_Replace ("),"); 2555 Write_Statement_Buffer; 2556 Set_String (" Value => ("); 2557 2558 for J in Cumulative_Restrictions.Value'Range loop 2559 Set_Int (Int (Cumulative_Restrictions.Value (J))); 2560 Set_String (", "); 2561 end loop; 2562 2563 Set_String_Replace ("),"); 2564 Write_Statement_Buffer; 2565 WBI (" Violated =>"); 2566 Set_String (" ("); 2567 Count := 0; 2568 2569 for J in Cumulative_Restrictions.Violated'Range loop 2570 Set_Boolean (Cumulative_Restrictions.Violated (J)); 2571 Set_String (", "); 2572 Count := Count + 1; 2573 2574 if J /= Cumulative_Restrictions.Set'Last and then Count = 8 then 2575 Write_Statement_Buffer; 2576 Set_String (" "); 2577 Count := 0; 2578 end if; 2579 end loop; 2580 2581 Set_String_Replace ("),"); 2582 Write_Statement_Buffer; 2583 Set_String (" Count => ("); 2584 2585 for J in Cumulative_Restrictions.Count'Range loop 2586 Set_Int (Int (Cumulative_Restrictions.Count (J))); 2587 Set_String (", "); 2588 end loop; 2589 2590 Set_String_Replace ("),"); 2591 Write_Statement_Buffer; 2592 Set_String (" Unknown => ("); 2593 2594 for J in Cumulative_Restrictions.Unknown'Range loop 2595 Set_Boolean (Cumulative_Restrictions.Unknown (J)); 2596 Set_String (", "); 2597 end loop; 2598 2599 Set_String_Replace ("))"); 2600 Set_String (";"); 2601 Write_Statement_Buffer; 2602 end Gen_Restrictions; 2603 2604 ------------------ 2605 -- Gen_Versions -- 2606 ------------------ 2607 2608 -- This routine generates lines such as: 2609 2610 -- unnnnn : constant Integer := 16#hhhhhhhh#; 2611 -- pragma Export (C, unnnnn, unam); 2612 2613 -- for each unit, where unam is the unit name suffixed by either B or S for 2614 -- body or spec, with dots replaced by double underscores, and hhhhhhhh is 2615 -- the version number, and nnnnn is a 5-digits serial number. 2616 2617 procedure Gen_Versions is 2618 Ubuf : String (1 .. 6) := "u00000"; 2619 2620 procedure Increment_Ubuf; 2621 -- Little procedure to increment the serial number 2622 2623 -------------------- 2624 -- Increment_Ubuf -- 2625 -------------------- 2626 2627 procedure Increment_Ubuf is 2628 begin 2629 for J in reverse Ubuf'Range loop 2630 Ubuf (J) := Character'Succ (Ubuf (J)); 2631 exit when Ubuf (J) <= '9'; 2632 Ubuf (J) := '0'; 2633 end loop; 2634 end Increment_Ubuf; 2635 2636 -- Start of processing for Gen_Versions 2637 2638 begin 2639 WBI (""); 2640 2641 WBI (" type Version_32 is mod 2 ** 32;"); 2642 for U in Units.First .. Units.Last loop 2643 if not Units.Table (U).SAL_Interface 2644 and then 2645 (not Bind_For_Library or else Units.Table (U).Directly_Scanned) 2646 then 2647 Increment_Ubuf; 2648 WBI (" " & Ubuf & " : constant Version_32 := 16#" & 2649 Units.Table (U).Version & "#;"); 2650 Set_String (" pragma Export (C, "); 2651 Set_String (Ubuf); 2652 Set_String (", """); 2653 2654 Get_Name_String (Units.Table (U).Uname); 2655 2656 for K in 1 .. Name_Len loop 2657 if Name_Buffer (K) = '.' then 2658 Set_Char ('_'); 2659 Set_Char ('_'); 2660 2661 elsif Name_Buffer (K) = '%' then 2662 exit; 2663 2664 else 2665 Set_Char (Name_Buffer (K)); 2666 end if; 2667 end loop; 2668 2669 if Name_Buffer (Name_Len) = 's' then 2670 Set_Char ('S'); 2671 else 2672 Set_Char ('B'); 2673 end if; 2674 2675 Set_String (""");"); 2676 Write_Statement_Buffer; 2677 end if; 2678 end loop; 2679 end Gen_Versions; 2680 2681 ------------------------ 2682 -- Get_Main_Unit_Name -- 2683 ------------------------ 2684 2685 function Get_Main_Unit_Name (S : String) return String is 2686 Result : String := S; 2687 2688 begin 2689 for J in S'Range loop 2690 if Result (J) = '.' then 2691 Result (J) := '_'; 2692 end if; 2693 end loop; 2694 2695 return Result; 2696 end Get_Main_Unit_Name; 2697 2698 ----------------------- 2699 -- Get_Ada_Main_Name -- 2700 ----------------------- 2701 2702 function Get_Ada_Main_Name return String is 2703 Suffix : constant String := "_00"; 2704 Name : String (1 .. Opt.Ada_Main_Name.all'Length + Suffix'Length) := 2705 Opt.Ada_Main_Name.all & Suffix; 2706 Nlen : Natural; 2707 2708 begin 2709 -- The main program generated by JGNAT expects a package called 2710 -- ada_<main procedure>. 2711 if VM_Target /= No_VM then 2712 Get_Name_String (Units.Table (First_Unit_Entry).Uname); 2713 return "ada_" & Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len - 2)); 2714 end if; 2715 2716 -- For CodePeer, we want reproducible names (independent of other 2717 -- mains that may or may not be present) that don't collide 2718 -- when analyzing multiple mains and which are easily recognizable 2719 -- as "ada_main" names. 2720 if CodePeer_Mode then 2721 Get_Name_String (Units.Table (First_Unit_Entry).Uname); 2722 return "ada_main_for_" & 2723 Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len - 2)); 2724 end if; 2725 2726 -- This loop tries the following possibilities in order 2727 -- <Ada_Main> 2728 -- <Ada_Main>_01 2729 -- <Ada_Main>_02 2730 -- .. 2731 -- <Ada_Main>_99 2732 -- where <Ada_Main> is equal to Opt.Ada_Main_Name. By default, 2733 -- it is set to 'ada_main'. 2734 2735 for J in 0 .. 99 loop 2736 if J = 0 then 2737 Nlen := Name'Length - Suffix'Length; 2738 else 2739 Nlen := Name'Length; 2740 Name (Name'Last) := Character'Val (J mod 10 + Character'Pos ('0')); 2741 Name (Name'Last - 1) := 2742 Character'Val (J / 10 + Character'Pos ('0')); 2743 end if; 2744 2745 for K in ALIs.First .. ALIs.Last loop 2746 for L in ALIs.Table (K).First_Unit .. ALIs.Table (K).Last_Unit loop 2747 2748 -- Get unit name, removing %b or %e at end 2749 2750 Get_Name_String (Units.Table (L).Uname); 2751 Name_Len := Name_Len - 2; 2752 2753 if Name_Buffer (1 .. Name_Len) = Name (1 .. Nlen) then 2754 goto Continue; 2755 end if; 2756 end loop; 2757 end loop; 2758 2759 return Name (1 .. Nlen); 2760 2761 <<Continue>> 2762 null; 2763 end loop; 2764 2765 -- If we fall through, just use a peculiar unlikely name 2766 2767 return ("Qwertyuiop"); 2768 end Get_Ada_Main_Name; 2769 2770 ------------------- 2771 -- Get_Main_Name -- 2772 ------------------- 2773 2774 function Get_Main_Name return String is 2775 begin 2776 -- Explicit name given with -M switch 2777 2778 if Bind_Alternate_Main_Name then 2779 return Alternate_Main_Name.all; 2780 2781 -- Case of main program name to be used directly 2782 2783 elsif Use_Ada_Main_Program_Name_On_Target then 2784 2785 -- Get main program name 2786 2787 Get_Name_String (Units.Table (First_Unit_Entry).Uname); 2788 2789 -- If this is a child name, return only the name of the child, since 2790 -- we can't have dots in a nested program name. Note that we do not 2791 -- include the %b at the end of the unit name. 2792 2793 for J in reverse 1 .. Name_Len - 2 loop 2794 if J = 1 or else Name_Buffer (J - 1) = '.' then 2795 return Name_Buffer (J .. Name_Len - 2); 2796 end if; 2797 end loop; 2798 2799 raise Program_Error; -- impossible exit 2800 2801 -- Case where "main" is to be used as default 2802 2803 else 2804 return "main"; 2805 end if; 2806 end Get_Main_Name; 2807 2808 --------------------- 2809 -- Get_WC_Encoding -- 2810 --------------------- 2811 2812 function Get_WC_Encoding return Character is 2813 begin 2814 -- If encoding method specified by -W switch, then return it 2815 2816 if Wide_Character_Encoding_Method_Specified then 2817 return WC_Encoding_Letters (Wide_Character_Encoding_Method); 2818 2819 -- If no main program, and not specified, set brackets, we really have 2820 -- no better choice. If some other encoding is required when there is 2821 -- no main, it must be set explicitly using -Wx. 2822 2823 -- Note: if the ALI file always passed the wide character encoding of 2824 -- every file, then we could use the encoding of the initial specified 2825 -- file, but this information is passed only for potential main 2826 -- programs. We could fix this sometime, but it is a very minor point 2827 -- (wide character default encoding for [Wide_[Wide_]Text_IO when there 2828 -- is no main program). 2829 2830 elsif No_Main_Subprogram then 2831 return 'b'; 2832 2833 -- Otherwise if there is a main program, take encoding from it 2834 2835 else 2836 return ALIs.Table (ALIs.First).WC_Encoding; 2837 end if; 2838 end Get_WC_Encoding; 2839 2840 ------------------- 2841 -- Has_Finalizer -- 2842 ------------------- 2843 2844 function Has_Finalizer return Boolean is 2845 U : Unit_Record; 2846 Unum : Unit_Id; 2847 2848 begin 2849 for E in reverse Elab_Order.First .. Elab_Order.Last loop 2850 Unum := Elab_Order.Table (E); 2851 U := Units.Table (Unum); 2852 2853 -- We are only interested in non-generic packages 2854 2855 if U.Unit_Kind = 'p' 2856 and then U.Has_Finalizer 2857 and then not U.Is_Generic 2858 and then not U.No_Elab 2859 then 2860 return True; 2861 end if; 2862 end loop; 2863 2864 return False; 2865 end Has_Finalizer; 2866 2867 ---------------------- 2868 -- Lt_Linker_Option -- 2869 ---------------------- 2870 2871 function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean is 2872 begin 2873 -- Sort internal files last 2874 2875 if Linker_Options.Table (Op1).Internal_File 2876 /= 2877 Linker_Options.Table (Op2).Internal_File 2878 then 2879 -- Note: following test uses False < True 2880 2881 return Linker_Options.Table (Op1).Internal_File 2882 < 2883 Linker_Options.Table (Op2).Internal_File; 2884 2885 -- If both internal or both non-internal, sort according to the 2886 -- elaboration position. A unit that is elaborated later should come 2887 -- earlier in the linker options list. 2888 2889 else 2890 return Units.Table (Linker_Options.Table (Op1).Unit).Elab_Position 2891 > 2892 Units.Table (Linker_Options.Table (Op2).Unit).Elab_Position; 2893 2894 end if; 2895 end Lt_Linker_Option; 2896 2897 ------------------------ 2898 -- Move_Linker_Option -- 2899 ------------------------ 2900 2901 procedure Move_Linker_Option (From : Natural; To : Natural) is 2902 begin 2903 Linker_Options.Table (To) := Linker_Options.Table (From); 2904 end Move_Linker_Option; 2905 2906 ---------------------------- 2907 -- Resolve_Binder_Options -- 2908 ---------------------------- 2909 2910 procedure Resolve_Binder_Options is 2911 2912 procedure Check_Package (Var : in out Boolean; Name : String); 2913 -- Set Var to true iff the current identifier in Namet is Name. Do 2914 -- nothing if it doesn't match. This procedure is just an helper to 2915 -- avoid to explicitely deal with length. 2916 2917 ------------------- 2918 -- Check_Package -- 2919 ------------------- 2920 2921 procedure Check_Package (Var : in out Boolean; Name : String) is 2922 begin 2923 if Name_Len = Name'Length 2924 and then Name_Buffer (1 .. Name_Len) = Name 2925 then 2926 Var := True; 2927 end if; 2928 end Check_Package; 2929 2930 -- Start of processing for Resolve_Binder_Options 2931 2932 begin 2933 for E in Elab_Order.First .. Elab_Order.Last loop 2934 Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname); 2935 2936 -- This is not a perfect approach, but is the current protocol 2937 -- between the run-time and the binder to indicate that tasking is 2938 -- used: System.OS_Interface should always be used by any tasking 2939 -- application. 2940 2941 Check_Package (With_GNARL, "system.os_interface%s"); 2942 2943 -- Ditto for the use of restricted tasking 2944 2945 Check_Package 2946 (System_Tasking_Restricted_Stages_Used, 2947 "system.tasking.restricted.stages%s"); 2948 2949 -- Ditto for the use of interrupts 2950 2951 Check_Package (System_Interrupts_Used, "system.interrupts%s"); 2952 2953 -- Ditto for the use of dispatching domains 2954 2955 Check_Package 2956 (Dispatching_Domains_Used, 2957 "system.multiprocessors.dispatching_domains%s"); 2958 2959 -- Ditto for the use of restrictions 2960 2961 Check_Package (System_Restrictions_Used, "system.restrictions%s"); 2962 end loop; 2963 end Resolve_Binder_Options; 2964 2965 ----------------- 2966 -- Set_Boolean -- 2967 ----------------- 2968 2969 procedure Set_Boolean (B : Boolean) is 2970 True_Str : constant String := "True"; 2971 False_Str : constant String := "False"; 2972 begin 2973 if B then 2974 Statement_Buffer (Last + 1 .. Last + True_Str'Length) := True_Str; 2975 Last := Last + True_Str'Length; 2976 else 2977 Statement_Buffer (Last + 1 .. Last + False_Str'Length) := False_Str; 2978 Last := Last + False_Str'Length; 2979 end if; 2980 end Set_Boolean; 2981 2982 -------------- 2983 -- Set_Char -- 2984 -------------- 2985 2986 procedure Set_Char (C : Character) is 2987 begin 2988 Last := Last + 1; 2989 Statement_Buffer (Last) := C; 2990 end Set_Char; 2991 2992 ------------- 2993 -- Set_Int -- 2994 ------------- 2995 2996 procedure Set_Int (N : Int) is 2997 begin 2998 if N < 0 then 2999 Set_String ("-"); 3000 Set_Int (-N); 3001 3002 else 3003 if N > 9 then 3004 Set_Int (N / 10); 3005 end if; 3006 3007 Last := Last + 1; 3008 Statement_Buffer (Last) := 3009 Character'Val (N mod 10 + Character'Pos ('0')); 3010 end if; 3011 end Set_Int; 3012 3013 ------------------------- 3014 -- Set_IS_Pragma_Table -- 3015 ------------------------- 3016 3017 procedure Set_IS_Pragma_Table is 3018 begin 3019 for F in ALIs.First .. ALIs.Last loop 3020 for K in ALIs.Table (F).First_Interrupt_State .. 3021 ALIs.Table (F).Last_Interrupt_State 3022 loop 3023 declare 3024 Inum : constant Int := 3025 Interrupt_States.Table (K).Interrupt_Id; 3026 Stat : constant Character := 3027 Interrupt_States.Table (K).Interrupt_State; 3028 3029 begin 3030 while IS_Pragma_Settings.Last < Inum loop 3031 IS_Pragma_Settings.Append ('n'); 3032 end loop; 3033 3034 IS_Pragma_Settings.Table (Inum) := Stat; 3035 end; 3036 end loop; 3037 end loop; 3038 end Set_IS_Pragma_Table; 3039 3040 --------------------------- 3041 -- Set_Main_Program_Name -- 3042 --------------------------- 3043 3044 procedure Set_Main_Program_Name is 3045 begin 3046 -- Note that name has %b on the end which we ignore 3047 3048 -- First we output the initial _ada_ since we know that the main 3049 -- program is a library level subprogram. 3050 3051 Set_String ("_ada_"); 3052 3053 -- Copy name, changing dots to double underscores 3054 3055 for J in 1 .. Name_Len - 2 loop 3056 if Name_Buffer (J) = '.' then 3057 Set_String ("__"); 3058 else 3059 Set_Char (Name_Buffer (J)); 3060 end if; 3061 end loop; 3062 end Set_Main_Program_Name; 3063 3064 --------------------- 3065 -- Set_Name_Buffer -- 3066 --------------------- 3067 3068 procedure Set_Name_Buffer is 3069 begin 3070 for J in 1 .. Name_Len loop 3071 Set_Char (Name_Buffer (J)); 3072 end loop; 3073 end Set_Name_Buffer; 3074 3075 ------------------------- 3076 -- Set_PSD_Pragma_Table -- 3077 ------------------------- 3078 3079 procedure Set_PSD_Pragma_Table is 3080 begin 3081 for F in ALIs.First .. ALIs.Last loop 3082 for K in ALIs.Table (F).First_Specific_Dispatching .. 3083 ALIs.Table (F).Last_Specific_Dispatching 3084 loop 3085 declare 3086 DTK : Specific_Dispatching_Record 3087 renames Specific_Dispatching.Table (K); 3088 3089 begin 3090 while PSD_Pragma_Settings.Last < DTK.Last_Priority loop 3091 PSD_Pragma_Settings.Append ('F'); 3092 end loop; 3093 3094 for Prio in DTK.First_Priority .. DTK.Last_Priority loop 3095 PSD_Pragma_Settings.Table (Prio) := DTK.Dispatching_Policy; 3096 end loop; 3097 end; 3098 end loop; 3099 end loop; 3100 end Set_PSD_Pragma_Table; 3101 3102 ---------------- 3103 -- Set_String -- 3104 ---------------- 3105 3106 procedure Set_String (S : String) is 3107 begin 3108 Statement_Buffer (Last + 1 .. Last + S'Length) := S; 3109 Last := Last + S'Length; 3110 end Set_String; 3111 3112 ------------------------ 3113 -- Set_String_Replace -- 3114 ------------------------ 3115 3116 procedure Set_String_Replace (S : String) is 3117 begin 3118 Statement_Buffer (Last - S'Length + 1 .. Last) := S; 3119 end Set_String_Replace; 3120 3121 ------------------- 3122 -- Set_Unit_Name -- 3123 ------------------- 3124 3125 procedure Set_Unit_Name (Mode : Qualification_Mode := Double_Underscores) is 3126 begin 3127 for J in 1 .. Name_Len - 2 loop 3128 if Name_Buffer (J) = '.' then 3129 if Mode = Double_Underscores then 3130 Set_String ("__"); 3131 elsif Mode = Dot then 3132 Set_Char ('.'); 3133 else 3134 Set_Char ('$'); 3135 end if; 3136 else 3137 Set_Char (Name_Buffer (J)); 3138 end if; 3139 end loop; 3140 end Set_Unit_Name; 3141 3142 --------------------- 3143 -- Set_Unit_Number -- 3144 --------------------- 3145 3146 procedure Set_Unit_Number (U : Unit_Id) is 3147 Num_Units : constant Nat := Nat (Units.Last) - Nat (Unit_Id'First); 3148 Unum : constant Nat := Nat (U) - Nat (Unit_Id'First); 3149 3150 begin 3151 if Num_Units >= 10 and then Unum < 10 then 3152 Set_Char ('0'); 3153 end if; 3154 3155 if Num_Units >= 100 and then Unum < 100 then 3156 Set_Char ('0'); 3157 end if; 3158 3159 Set_Int (Unum); 3160 end Set_Unit_Number; 3161 3162 ---------------------------- 3163 -- Write_Statement_Buffer -- 3164 ---------------------------- 3165 3166 procedure Write_Statement_Buffer is 3167 begin 3168 WBI (Statement_Buffer (1 .. Last)); 3169 Last := 0; 3170 end Write_Statement_Buffer; 3171 3172 procedure Write_Statement_Buffer (S : String) is 3173 begin 3174 Set_String (S); 3175 Write_Statement_Buffer; 3176 end Write_Statement_Buffer; 3177 3178end Bindgen; 3179