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