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