1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- G N A T B I N D -- 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 ALI.Util; use ALI.Util; 28with Bcheck; use Bcheck; 29with Binde; use Binde; 30with Binderr; use Binderr; 31with Bindgen; use Bindgen; 32with Bindusg; 33with Butil; use Butil; 34with Casing; use Casing; 35with Csets; 36with Debug; use Debug; 37with Fmap; 38with Fname; use Fname; 39with Namet; use Namet; 40with Opt; use Opt; 41with Osint; use Osint; 42with Osint.B; use Osint.B; 43with Output; use Output; 44with Rident; use Rident; 45with Snames; 46with Switch; use Switch; 47with Switch.B; use Switch.B; 48with Table; 49with Targparm; use Targparm; 50with Types; use Types; 51 52with System.Case_Util; use System.Case_Util; 53with System.OS_Lib; use System.OS_Lib; 54 55with Ada.Command_Line.Response_File; use Ada.Command_Line; 56 57procedure Gnatbind is 58 59 Total_Errors : Nat := 0; 60 -- Counts total errors in all files 61 62 Total_Warnings : Nat := 0; 63 -- Total warnings in all files 64 65 Main_Lib_File : File_Name_Type; 66 -- Current main library file 67 68 First_Main_Lib_File : File_Name_Type := No_File; 69 -- The first library file, that should be a main subprogram if neither -n 70 -- nor -z are used. 71 72 Std_Lib_File : File_Name_Type; 73 -- Standard library 74 75 Text : Text_Buffer_Ptr; 76 77 Output_File_Name_Seen : Boolean := False; 78 Output_File_Name : String_Ptr := new String'(""); 79 80 Mapping_File : String_Ptr := null; 81 82 package Closure_Sources is new Table.Table 83 (Table_Component_Type => File_Name_Type, 84 Table_Index_Type => Natural, 85 Table_Low_Bound => 1, 86 Table_Initial => 10, 87 Table_Increment => 100, 88 Table_Name => "Gnatbind.Closure_Sources"); 89 -- Table to record the sources in the closure, to avoid duplications. Used 90 -- only with switch -R. 91 92 function Gnatbind_Supports_Auto_Init return Boolean; 93 -- Indicates if automatic initialization of elaboration procedure 94 -- through the constructor mechanism is possible on the platform. 95 96 procedure List_Applicable_Restrictions; 97 -- List restrictions that apply to this partition if option taken 98 99 procedure Scan_Bind_Arg (Argv : String); 100 -- Scan and process binder specific arguments. Argv is a single argument. 101 -- All the one character arguments are still handled by Switch. This 102 -- routine handles -aO -aI and -I-. The lower bound of Argv must be 1. 103 104 generic 105 with procedure Action (Argv : String); 106 procedure Generic_Scan_Bind_Args; 107 -- Iterate through the args calling Action on each one, taking care of 108 -- response files. 109 110 procedure Write_Arg (S : String); 111 -- Passed to Generic_Scan_Bind_Args to print args 112 113 function Is_Cross_Compiler return Boolean; 114 -- Returns True iff this is a cross-compiler 115 116 --------------------------------- 117 -- Gnatbind_Supports_Auto_Init -- 118 --------------------------------- 119 120 function Gnatbind_Supports_Auto_Init return Boolean is 121 function gnat_binder_supports_auto_init return Integer; 122 pragma Import (C, gnat_binder_supports_auto_init, 123 "__gnat_binder_supports_auto_init"); 124 begin 125 return gnat_binder_supports_auto_init /= 0; 126 end Gnatbind_Supports_Auto_Init; 127 128 ----------------------- 129 -- Is_Cross_Compiler -- 130 ----------------------- 131 132 function Is_Cross_Compiler return Boolean is 133 Cross_Compiler : Integer; 134 pragma Import (C, Cross_Compiler, "__gnat_is_cross_compiler"); 135 begin 136 return Cross_Compiler = 1; 137 end Is_Cross_Compiler; 138 139 ---------------------------------- 140 -- List_Applicable_Restrictions -- 141 ---------------------------------- 142 143 procedure List_Applicable_Restrictions is 144 145 -- Define those restrictions that should be output if the gnatbind 146 -- -r switch is used. Not all restrictions are output for the reasons 147 -- given below in the list, and this array is used to test whether 148 -- the corresponding pragma should be listed. True means that it 149 -- should not be listed. 150 151 No_Restriction_List : constant array (All_Restrictions) of Boolean := 152 (No_Standard_Allocators_After_Elaboration => True, 153 -- This involves run-time conditions not checkable at compile time 154 155 No_Anonymous_Allocators => True, 156 -- Premature, since we have not implemented this yet 157 158 No_Exception_Propagation => True, 159 -- Modifies code resulting in different exception semantics 160 161 No_Exceptions => True, 162 -- Has unexpected Suppress (All_Checks) effect 163 164 No_Implicit_Conditionals => True, 165 -- This could modify and pessimize generated code 166 167 No_Implicit_Dynamic_Code => True, 168 -- This could modify and pessimize generated code 169 170 No_Implicit_Loops => True, 171 -- This could modify and pessimize generated code 172 173 No_Recursion => True, 174 -- Not checkable at compile time 175 176 No_Reentrancy => True, 177 -- Not checkable at compile time 178 179 Max_Entry_Queue_Length => True, 180 -- Not checkable at compile time 181 182 Max_Storage_At_Blocking => True, 183 -- Not checkable at compile time 184 185 -- The following three should not be partition-wide, so the 186 -- following tests are junk to be removed eventually ??? 187 188 No_Specification_Of_Aspect => True, 189 -- Requires a parameter value, not a count 190 191 No_Use_Of_Attribute => True, 192 -- Requires a parameter value, not a count 193 194 No_Use_Of_Pragma => True, 195 -- Requires a parameter value, not a count 196 197 others => False); 198 199 Additional_Restrictions_Listed : Boolean := False; 200 -- Set True if we have listed header for restrictions 201 202 function Restriction_Could_Be_Set (R : Restriction_Id) return Boolean; 203 -- Returns True if the given restriction can be listed as an additional 204 -- restriction that could be set. 205 206 ------------------------------ 207 -- Restriction_Could_Be_Set -- 208 ------------------------------ 209 210 function Restriction_Could_Be_Set (R : Restriction_Id) return Boolean is 211 CR : Restrictions_Info renames Cumulative_Restrictions; 212 213 begin 214 case R is 215 216 -- Boolean restriction 217 218 when All_Boolean_Restrictions => 219 220 -- The condition for listing a boolean restriction as an 221 -- additional restriction that could be set is that it is 222 -- not violated by any unit, and not already set. 223 224 return CR.Violated (R) = False and then CR.Set (R) = False; 225 226 -- Parameter restriction 227 228 when All_Parameter_Restrictions => 229 230 -- If the restriction is violated and the level of violation is 231 -- unknown, the restriction can definitely not be listed. 232 233 if CR.Violated (R) and then CR.Unknown (R) then 234 return False; 235 236 -- We can list the restriction if it is not set 237 238 elsif not CR.Set (R) then 239 return True; 240 241 -- We can list the restriction if is set to a greater value 242 -- than the maximum value known for the violation. 243 244 else 245 return CR.Value (R) > CR.Count (R); 246 end if; 247 248 -- No other values for R possible 249 250 when others => 251 raise Program_Error; 252 253 end case; 254 end Restriction_Could_Be_Set; 255 256 -- Start of processing for List_Applicable_Restrictions 257 258 begin 259 -- Loop through restrictions 260 261 for R in All_Restrictions loop 262 if not No_Restriction_List (R) 263 and then Restriction_Could_Be_Set (R) 264 then 265 if not Additional_Restrictions_Listed then 266 Write_Eol; 267 Write_Line 268 ("The following additional restrictions may be" & 269 " applied to this partition:"); 270 Additional_Restrictions_Listed := True; 271 end if; 272 273 Write_Str ("pragma Restrictions ("); 274 275 declare 276 S : constant String := Restriction_Id'Image (R); 277 begin 278 Name_Len := S'Length; 279 Name_Buffer (1 .. Name_Len) := S; 280 end; 281 282 Set_Casing (Mixed_Case); 283 Write_Str (Name_Buffer (1 .. Name_Len)); 284 285 if R in All_Parameter_Restrictions then 286 Write_Str (" => "); 287 Write_Int (Int (Cumulative_Restrictions.Count (R))); 288 end if; 289 290 Write_Str (");"); 291 Write_Eol; 292 end if; 293 end loop; 294 end List_Applicable_Restrictions; 295 296 ------------------- 297 -- Scan_Bind_Arg -- 298 ------------------- 299 300 procedure Scan_Bind_Arg (Argv : String) is 301 pragma Assert (Argv'First = 1); 302 303 begin 304 -- Now scan arguments that are specific to the binder and are not 305 -- handled by the common circuitry in Switch. 306 307 if Opt.Output_File_Name_Present 308 and then not Output_File_Name_Seen 309 then 310 Output_File_Name_Seen := True; 311 312 if Argv'Length = 0 313 or else (Argv'Length >= 1 and then Argv (1) = '-') 314 then 315 Fail ("output File_Name missing after -o"); 316 317 else 318 Output_File_Name := new String'(Argv); 319 end if; 320 321 elsif Argv'Length >= 2 and then Argv (1) = '-' then 322 323 -- -I- 324 325 if Argv (2 .. Argv'Last) = "I-" then 326 Opt.Look_In_Primary_Dir := False; 327 328 -- -Idir 329 330 elsif Argv (2) = 'I' then 331 Add_Src_Search_Dir (Argv (3 .. Argv'Last)); 332 Add_Lib_Search_Dir (Argv (3 .. Argv'Last)); 333 334 -- -Ldir 335 336 elsif Argv (2) = 'L' then 337 if Argv'Length >= 3 then 338 339 Opt.Bind_For_Library := True; 340 Opt.Ada_Init_Name := 341 new String'(Argv (3 .. Argv'Last) & Opt.Ada_Init_Suffix); 342 Opt.Ada_Final_Name := 343 new String'(Argv (3 .. Argv'Last) & Opt.Ada_Final_Suffix); 344 Opt.Ada_Main_Name := 345 new String'(Argv (3 .. Argv'Last) & Opt.Ada_Main_Name_Suffix); 346 347 -- This option (-Lxxx) implies -n 348 349 Opt.Bind_Main_Program := False; 350 351 else 352 Fail 353 ("Prefix of initialization and finalization " & 354 "procedure names missing in -L"); 355 end if; 356 357 -- -Sin -Slo -Shi -Sxx -Sev 358 359 elsif Argv'Length = 4 360 and then Argv (2) = 'S' 361 then 362 declare 363 C1 : Character := Argv (3); 364 C2 : Character := Argv (4); 365 366 begin 367 -- Fold to upper case 368 369 if C1 in 'a' .. 'z' then 370 C1 := Character'Val (Character'Pos (C1) - 32); 371 end if; 372 373 if C2 in 'a' .. 'z' then 374 C2 := Character'Val (Character'Pos (C2) - 32); 375 end if; 376 377 -- Test valid option and set mode accordingly 378 379 if C1 = 'E' and then C2 = 'V' then 380 null; 381 382 elsif C1 = 'I' and then C2 = 'N' then 383 null; 384 385 elsif C1 = 'L' and then C2 = 'O' then 386 null; 387 388 elsif C1 = 'H' and then C2 = 'I' then 389 null; 390 391 elsif (C1 in '0' .. '9' or else C1 in 'A' .. 'F') 392 and then 393 (C2 in '0' .. '9' or else C2 in 'A' .. 'F') 394 then 395 null; 396 397 -- Invalid -S switch, let Switch give error, set default of IN 398 399 else 400 Scan_Binder_Switches (Argv); 401 C1 := 'I'; 402 C2 := 'N'; 403 end if; 404 405 Initialize_Scalars_Mode1 := C1; 406 Initialize_Scalars_Mode2 := C2; 407 end; 408 409 -- -aIdir 410 411 elsif Argv'Length >= 3 412 and then Argv (2 .. 3) = "aI" 413 then 414 Add_Src_Search_Dir (Argv (4 .. Argv'Last)); 415 416 -- -aOdir 417 418 elsif Argv'Length >= 3 419 and then Argv (2 .. 3) = "aO" 420 then 421 Add_Lib_Search_Dir (Argv (4 .. Argv'Last)); 422 423 -- -nostdlib 424 425 elsif Argv (2 .. Argv'Last) = "nostdlib" then 426 Opt.No_Stdlib := True; 427 428 -- -nostdinc 429 430 elsif Argv (2 .. Argv'Last) = "nostdinc" then 431 Opt.No_Stdinc := True; 432 433 -- -static 434 435 elsif Argv (2 .. Argv'Last) = "static" then 436 Opt.Shared_Libgnat := False; 437 438 -- -shared 439 440 elsif Argv (2 .. Argv'Last) = "shared" then 441 Opt.Shared_Libgnat := True; 442 443 -- -F=mapping_file 444 445 elsif Argv'Length >= 4 and then Argv (2 .. 3) = "F=" then 446 if Mapping_File /= null then 447 Fail ("cannot specify several mapping files"); 448 end if; 449 450 Mapping_File := new String'(Argv (4 .. Argv'Last)); 451 452 -- -Mname 453 454 elsif Argv'Length >= 3 and then Argv (2) = 'M' then 455 if not Is_Cross_Compiler then 456 Write_Line 457 ("gnatbind: -M not expected to be used on native platforms"); 458 end if; 459 460 Opt.Bind_Alternate_Main_Name := True; 461 Opt.Alternate_Main_Name := new String'(Argv (3 .. Argv'Last)); 462 463 -- All other options are single character and are handled by 464 -- Scan_Binder_Switches. 465 466 else 467 Scan_Binder_Switches (Argv); 468 end if; 469 470 -- Not a switch, so must be a file name (if non-empty) 471 472 elsif Argv'Length /= 0 then 473 if Argv'Length > 4 474 and then Argv (Argv'Last - 3 .. Argv'Last) = ".ali" 475 then 476 Add_File (Argv); 477 else 478 Add_File (Argv & ".ali"); 479 end if; 480 end if; 481 end Scan_Bind_Arg; 482 483 ---------------------------- 484 -- Generic_Scan_Bind_Args -- 485 ---------------------------- 486 487 procedure Generic_Scan_Bind_Args is 488 Next_Arg : Positive := 1; 489 490 begin 491 -- Use low level argument routines to avoid dragging in secondary stack 492 493 while Next_Arg < Arg_Count loop 494 declare 495 Next_Argv : String (1 .. Len_Arg (Next_Arg)); 496 497 begin 498 Fill_Arg (Next_Argv'Address, Next_Arg); 499 500 if Next_Argv'Length > 0 then 501 if Next_Argv (1) = '@' then 502 if Next_Argv'Length > 1 then 503 declare 504 Arguments : constant Argument_List := 505 Response_File.Arguments_From 506 (Response_File_Name => 507 Next_Argv (2 .. Next_Argv'Last), 508 Recursive => True, 509 Ignore_Non_Existing_Files => True); 510 begin 511 for J in Arguments'Range loop 512 Action (Arguments (J).all); 513 end loop; 514 end; 515 end if; 516 517 else 518 Action (Next_Argv); 519 end if; 520 end if; 521 end; 522 523 Next_Arg := Next_Arg + 1; 524 end loop; 525 end Generic_Scan_Bind_Args; 526 527 --------------- 528 -- Write_Arg -- 529 --------------- 530 531 procedure Write_Arg (S : String) is 532 begin 533 Write_Str (" " & S); 534 end Write_Arg; 535 536 procedure Scan_Bind_Args is new Generic_Scan_Bind_Args (Scan_Bind_Arg); 537 procedure Put_Bind_Args is new Generic_Scan_Bind_Args (Write_Arg); 538 539 procedure Check_Version_And_Help is 540 new Check_Version_And_Help_G (Bindusg.Display); 541 542-- Start of processing for Gnatbind 543 544begin 545 -- Set default for Shared_Libgnat option 546 547 declare 548 Shared_Libgnat_Default : Character; 549 pragma Import 550 (C, Shared_Libgnat_Default, "__gnat_shared_libgnat_default"); 551 552 SHARED : constant Character := 'H'; 553 STATIC : constant Character := 'T'; 554 555 begin 556 pragma Assert 557 (Shared_Libgnat_Default = SHARED 558 or else 559 Shared_Libgnat_Default = STATIC); 560 Shared_Libgnat := (Shared_Libgnat_Default = SHARED); 561 end; 562 563 -- Carry out package initializations. These are initializations which 564 -- might logically be performed at elaboration time, and we decide to be 565 -- consistent. Like elaboration, the order in which these calls are made 566 -- is in some cases important. 567 568 Csets.Initialize; 569 Snames.Initialize; 570 571 -- Scan the switches and arguments. Note that Snames must already be 572 -- initialized (for processing of the -V switch). 573 574 -- First, scan to detect --version and/or --help 575 576 Check_Version_And_Help ("GNATBIND", "1992"); 577 578 -- We need to Scan_Bind_Args first, to set Verbose_Mode, so we know whether 579 -- to Put_Bind_Args. 580 581 Scan_Bind_Args; 582 583 if Verbose_Mode then 584 Write_Str (Command_Name); 585 Put_Bind_Args; 586 Write_Eol; 587 end if; 588 589 if Use_Pragma_Linker_Constructor then 590 if Bind_Main_Program then 591 Fail ("switch -a must be used in conjunction with -n or -Lxxx"); 592 593 elsif not Gnatbind_Supports_Auto_Init then 594 Fail ("automatic initialisation of elaboration " & 595 "not supported on this platform"); 596 end if; 597 end if; 598 599 -- Test for trailing -o switch 600 601 if Opt.Output_File_Name_Present and then not Output_File_Name_Seen then 602 Fail ("output file name missing after -o"); 603 end if; 604 605 -- Output usage if requested 606 607 if Usage_Requested then 608 Bindusg.Display; 609 end if; 610 611 -- Check that the binder file specified has extension .adb 612 613 if Opt.Output_File_Name_Present and then Output_File_Name_Seen then 614 Check_Extensions : declare 615 Length : constant Natural := Output_File_Name'Length; 616 Last : constant Natural := Output_File_Name'Last; 617 begin 618 if Length <= 4 619 or else Output_File_Name (Last - 3 .. Last) /= ".adb" 620 then 621 Fail ("output file name should have .adb extension"); 622 end if; 623 end Check_Extensions; 624 end if; 625 626 Osint.Add_Default_Search_Dirs; 627 628 -- Acquire target parameters 629 630 Targparm.Get_Target_Parameters; 631 632 -- Initialize Cumulative_Restrictions with the restrictions on the target 633 -- scanned from the system.ads file. Then as we read ALI files, we will 634 -- accumulate additional restrictions specified in other files. 635 636 Cumulative_Restrictions := Targparm.Restrictions_On_Target; 637 638 -- Acquire configurable run-time mode 639 640 if Configurable_Run_Time_On_Target then 641 Configurable_Run_Time_Mode := True; 642 end if; 643 644 -- Output copyright notice if in verbose mode 645 646 if Verbose_Mode then 647 Write_Eol; 648 Display_Version ("GNATBIND", "1995"); 649 end if; 650 651 -- Output usage information if no arguments 652 653 if not More_Lib_Files then 654 if Argument_Count = 0 then 655 Bindusg.Display; 656 else 657 Write_Line ("try ""gnatbind --help"" for more information."); 658 end if; 659 660 Exit_Program (E_Fatal); 661 end if; 662 663 -- If a mapping file was specified, initialize the file mapping 664 665 if Mapping_File /= null then 666 Fmap.Initialize (Mapping_File.all); 667 end if; 668 669 -- The block here is to catch the Unrecoverable_Error exception in the 670 -- case where we exceed the maximum number of permissible errors or some 671 -- other unrecoverable error occurs. 672 673 begin 674 -- Initialize binder packages 675 676 Initialize_Binderr; 677 Initialize_ALI; 678 Initialize_ALI_Source; 679 680 if Verbose_Mode then 681 Write_Eol; 682 end if; 683 684 -- Input ALI files 685 686 while More_Lib_Files loop 687 Main_Lib_File := Next_Main_Lib_File; 688 689 if First_Main_Lib_File = No_File then 690 First_Main_Lib_File := Main_Lib_File; 691 end if; 692 693 if Verbose_Mode then 694 if Check_Only then 695 Write_Str ("Checking: "); 696 else 697 Write_Str ("Binding: "); 698 end if; 699 700 Write_Name (Main_Lib_File); 701 Write_Eol; 702 end if; 703 704 Text := Read_Library_Info (Main_Lib_File, True); 705 706 declare 707 Id : ALI_Id; 708 pragma Warnings (Off, Id); 709 710 begin 711 Id := Scan_ALI 712 (F => Main_Lib_File, 713 T => Text, 714 Ignore_ED => False, 715 Err => False, 716 Ignore_Errors => Debug_Flag_I, 717 Directly_Scanned => True); 718 end; 719 720 Free (Text); 721 end loop; 722 723 -- No_Run_Time mode 724 725 if No_Run_Time_Mode then 726 727 -- Set standard configuration parameters 728 729 Suppress_Standard_Library_On_Target := True; 730 Configurable_Run_Time_Mode := True; 731 end if; 732 733 -- For main ALI files, even if they are interfaces, we get their 734 -- dependencies. To be sure, we reset the Interface flag for all main 735 -- ALI files. 736 737 for Index in ALIs.First .. ALIs.Last loop 738 ALIs.Table (Index).SAL_Interface := False; 739 end loop; 740 741 -- Add System.Standard_Library to list to ensure that these files are 742 -- included in the bind, even if not directly referenced from Ada code 743 -- This is suppressed if the appropriate targparm switch is set. 744 745 if not Suppress_Standard_Library_On_Target then 746 Name_Buffer (1 .. 12) := "s-stalib.ali"; 747 Name_Len := 12; 748 Std_Lib_File := Name_Find; 749 Text := Read_Library_Info (Std_Lib_File, True); 750 751 declare 752 Id : ALI_Id; 753 pragma Warnings (Off, Id); 754 755 begin 756 Id := 757 Scan_ALI 758 (F => Std_Lib_File, 759 T => Text, 760 Ignore_ED => False, 761 Err => False, 762 Ignore_Errors => Debug_Flag_I); 763 end; 764 765 Free (Text); 766 end if; 767 768 -- Load ALIs for all dependent units 769 770 for Index in ALIs.First .. ALIs.Last loop 771 Read_Withed_ALIs (Index); 772 end loop; 773 774 -- Quit if some file needs compiling 775 776 if No_Object_Specified then 777 raise Unrecoverable_Error; 778 end if; 779 780 -- Quit with message if we had a GNATprove file 781 782 if GNATprove_Mode_Specified then 783 Error_Msg ("one or more files compiled in GNATprove mode"); 784 raise Unrecoverable_Error; 785 end if; 786 787 -- Output list of ALI files in closure 788 789 if Output_ALI_List then 790 if ALI_List_Filename /= null then 791 Set_List_File (ALI_List_Filename.all); 792 end if; 793 794 for Index in ALIs.First .. ALIs.Last loop 795 declare 796 Full_Afile : constant File_Name_Type := 797 Find_File (ALIs.Table (Index).Afile, Library); 798 begin 799 Write_Name (Full_Afile); 800 Write_Eol; 801 end; 802 end loop; 803 804 if ALI_List_Filename /= null then 805 Close_List_File; 806 end if; 807 end if; 808 809 -- Build source file table from the ALI files we have read in 810 811 Set_Source_Table; 812 813 -- If there is main program to bind, set Main_Lib_File to the first 814 -- library file, and the name from which to derive the binder generate 815 -- file to the first ALI file. 816 817 if Bind_Main_Program then 818 Main_Lib_File := First_Main_Lib_File; 819 Set_Current_File_Name_Index (To => 1); 820 end if; 821 822 -- Check that main library file is a suitable main program 823 824 if Bind_Main_Program 825 and then ALIs.Table (ALIs.First).Main_Program = None 826 and then not No_Main_Subprogram 827 then 828 Get_Name_String 829 (Units.Table (ALIs.Table (ALIs.First).First_Unit).Uname); 830 831 declare 832 Unit_Name : String := Name_Buffer (1 .. Name_Len - 2); 833 begin 834 To_Mixed (Unit_Name); 835 Get_Name_String (ALIs.Table (ALIs.First).Sfile); 836 Add_Str_To_Name_Buffer (":1: "); 837 Add_Str_To_Name_Buffer (Unit_Name); 838 Add_Str_To_Name_Buffer (" cannot be used as a main program"); 839 Write_Line (Name_Buffer (1 .. Name_Len)); 840 Errors_Detected := Errors_Detected + 1; 841 end; 842 end if; 843 844 -- Perform consistency and correctness checks 845 846 Check_Duplicated_Subunits; 847 Check_Versions; 848 Check_Consistency; 849 Check_Configuration_Consistency; 850 851 -- List restrictions that could be applied to this partition 852 853 if List_Restrictions then 854 List_Applicable_Restrictions; 855 end if; 856 857 -- Complete bind if no errors 858 859 if Errors_Detected = 0 then 860 Find_Elab_Order; 861 862 if Errors_Detected = 0 then 863 -- Display elaboration order if -l was specified 864 865 if Elab_Order_Output then 866 if not Zero_Formatting then 867 Write_Eol; 868 Write_Str ("ELABORATION ORDER"); 869 Write_Eol; 870 end if; 871 872 for J in Elab_Order.First .. Elab_Order.Last loop 873 if not Units.Table (Elab_Order.Table (J)).SAL_Interface then 874 if not Zero_Formatting then 875 Write_Str (" "); 876 end if; 877 878 Write_Unit_Name 879 (Units.Table (Elab_Order.Table (J)).Uname); 880 Write_Eol; 881 end if; 882 end loop; 883 884 if not Zero_Formatting then 885 Write_Eol; 886 end if; 887 end if; 888 889 if not Check_Only then 890 Gen_Output_File (Output_File_Name.all); 891 end if; 892 893 -- Display list of sources in the closure (except predefined 894 -- sources) if -R was used. 895 896 if List_Closure then 897 List_Closure_Display : declare 898 Source : File_Name_Type; 899 900 function Put_In_Sources (S : File_Name_Type) return Boolean; 901 -- Check if S is already in table Sources and put in Sources 902 -- if it is not. Return False if the source is already in 903 -- Sources, and True if it is added. 904 905 -------------------- 906 -- Put_In_Sources -- 907 -------------------- 908 909 function Put_In_Sources 910 (S : File_Name_Type) return Boolean 911 is 912 begin 913 for J in 1 .. Closure_Sources.Last loop 914 if Closure_Sources.Table (J) = S then 915 return False; 916 end if; 917 end loop; 918 919 Closure_Sources.Append (S); 920 return True; 921 end Put_In_Sources; 922 923 -- Start of processing for List_Closure_Display 924 925 begin 926 Closure_Sources.Init; 927 928 if not Zero_Formatting then 929 Write_Eol; 930 Write_Str ("REFERENCED SOURCES"); 931 Write_Eol; 932 end if; 933 934 for J in reverse Elab_Order.First .. Elab_Order.Last loop 935 Source := Units.Table (Elab_Order.Table (J)).Sfile; 936 937 -- Do not include same source more than once 938 939 if Put_In_Sources (Source) 940 941 -- Do not include run-time units unless -Ra switch set 942 943 and then (List_Closure_All 944 or else not Is_Internal_File_Name (Source)) 945 then 946 if not Zero_Formatting then 947 Write_Str (" "); 948 end if; 949 950 Write_Str (Get_Name_String (Source)); 951 Write_Eol; 952 end if; 953 end loop; 954 955 -- Subunits do not appear in the elaboration table because 956 -- they are subsumed by their parent units, but we need to 957 -- list them for other tools. For now they are listed after 958 -- other files, rather than right after their parent, since 959 -- there is no easy link between the elaboration table and 960 -- the ALIs table ??? As subunits may appear repeatedly in 961 -- the list, if the parent unit appears in the context of 962 -- several units in the closure, duplicates are suppressed. 963 964 for J in Sdep.First .. Sdep.Last loop 965 Source := Sdep.Table (J).Sfile; 966 967 if Sdep.Table (J).Subunit_Name /= No_Name 968 and then Put_In_Sources (Source) 969 and then not Is_Internal_File_Name (Source) 970 then 971 if not Zero_Formatting then 972 Write_Str (" "); 973 end if; 974 975 Write_Str (Get_Name_String (Source)); 976 Write_Eol; 977 end if; 978 end loop; 979 980 if not Zero_Formatting then 981 Write_Eol; 982 end if; 983 end List_Closure_Display; 984 end if; 985 end if; 986 end if; 987 988 Total_Errors := Total_Errors + Errors_Detected; 989 Total_Warnings := Total_Warnings + Warnings_Detected; 990 991 exception 992 when Unrecoverable_Error => 993 Total_Errors := Total_Errors + Errors_Detected; 994 Total_Warnings := Total_Warnings + Warnings_Detected; 995 end; 996 997 -- All done. Set proper exit status 998 999 Finalize_Binderr; 1000 Namet.Finalize; 1001 1002 if Total_Errors > 0 then 1003 Exit_Program (E_Errors); 1004 1005 elsif Total_Warnings > 0 then 1006 Exit_Program (E_Warnings); 1007 1008 else 1009 -- Do not call Exit_Program (E_Success), so that finalization occurs 1010 -- normally. 1011 1012 null; 1013 end if; 1014end Gnatbind; 1015