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