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