1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- G N A T 1 D R V -- 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 Atree; use Atree; 28with Back_End; use Back_End; 29with Comperr; 30with Csets; use Csets; 31with Debug; use Debug; 32with Elists; 33with Errout; use Errout; 34with Fmap; 35with Fname; use Fname; 36with Fname.UF; use Fname.UF; 37with Frontend; 38with Gnatvsn; use Gnatvsn; 39with Hostparm; 40with Inline; 41with Lib; use Lib; 42with Lib.Writ; use Lib.Writ; 43with Lib.Xref; 44with Namet; use Namet; 45with Nlists; 46with Opt; use Opt; 47with Osint; use Osint; 48with Output; use Output; 49with Prepcomp; 50with Repinfo; use Repinfo; 51with Restrict; 52with Rident; 53with Sem; 54with Sem_Ch8; 55with Sem_Ch12; 56with Sem_Ch13; 57with Sem_Elim; 58with Sem_Eval; 59with Sem_Type; 60with Sinfo; use Sinfo; 61with Sinput.L; use Sinput.L; 62with Snames; 63with Sprint; use Sprint; 64with Stringt; 65with Targparm; 66with Tree_Gen; 67with Treepr; use Treepr; 68with Ttypes; 69with Types; use Types; 70with Uintp; use Uintp; 71with Uname; use Uname; 72with Urealp; 73with Usage; 74 75with System.Assertions; 76 77procedure Gnat1drv is 78 Main_Unit_Node : Node_Id; 79 -- Compilation unit node for main unit 80 81 Main_Kind : Node_Kind; 82 -- Kind of main compilation unit node. 83 84 Back_End_Mode : Back_End.Back_End_Mode_Type; 85 -- Record back end mode 86 87begin 88 -- This inner block is set up to catch assertion errors and constraint 89 -- errors. Since the code for handling these errors can cause another 90 -- exception to be raised (namely Unrecoverable_Error), we need two 91 -- nested blocks, so that the outer one handles unrecoverable error. 92 93 begin 94 -- Lib.Initialize need to be called before Scan_Compiler_Arguments, 95 -- because it initialize a table that is filled by 96 -- Scan_Compiler_Arguments. 97 98 Osint.Initialize; 99 Fmap.Reset_Tables; 100 Lib.Initialize; 101 Lib.Xref.Initialize; 102 Scan_Compiler_Arguments; 103 Osint.Add_Default_Search_Dirs; 104 105 Nlists.Initialize; 106 Sinput.Initialize; 107 Sem.Initialize; 108 Csets.Initialize; 109 Uintp.Initialize; 110 Urealp.Initialize; 111 Errout.Initialize; 112 Namet.Initialize; 113 Snames.Initialize; 114 Stringt.Initialize; 115 Inline.Initialize; 116 Sem_Ch8.Initialize; 117 Sem_Ch12.Initialize; 118 Sem_Ch13.Initialize; 119 Sem_Elim.Initialize; 120 Sem_Eval.Initialize; 121 Sem_Type.Init_Interp_Tables; 122 123 -- Acquire target parameters from system.ads (source of package System) 124 125 declare 126 use Sinput; 127 128 S : Source_File_Index; 129 N : Name_Id; 130 R : Restrict.Restriction_Id; 131 P : Restrict.Restriction_Parameter_Id; 132 133 begin 134 Name_Buffer (1 .. 10) := "system.ads"; 135 Name_Len := 10; 136 N := Name_Find; 137 S := Load_Source_File (N); 138 139 if S = No_Source_File then 140 Write_Line 141 ("fatal error, run-time library not installed correctly"); 142 Write_Line 143 ("cannot locate file system.ads"); 144 raise Unrecoverable_Error; 145 146 -- Here if system.ads successfully read. Remember its source index. 147 148 else 149 System_Source_File_Index := S; 150 end if; 151 152 Targparm.Get_Target_Parameters 153 (System_Text => Source_Text (S), 154 Source_First => Source_First (S), 155 Source_Last => Source_Last (S)); 156 157 -- Acquire configuration pragma information from Targparm 158 159 for J in Rident.Partition_Restrictions loop 160 R := Restrict.Partition_Restrictions (J); 161 162 if Targparm.Restrictions_On_Target (J) then 163 Restrict.Restrictions (R) := True; 164 Restrict.Restrictions_Loc (R) := System_Location; 165 end if; 166 end loop; 167 168 for K in Rident.Restriction_Parameter_Id loop 169 P := Restrict.Restriction_Parameter_Id (K); 170 171 if Targparm.Restriction_Parameters_On_Target (K) /= No_Uint then 172 Restrict.Restriction_Parameters (P) := 173 Targparm.Restriction_Parameters_On_Target (K); 174 Restrict.Restriction_Parameters_Loc (P) := System_Location; 175 end if; 176 end loop; 177 end; 178 179 -- Set Configurable_Run_Time mode if system.ads flag set 180 181 if Targparm.Configurable_Run_Time_On_Target or Debug_Flag_YY then 182 Configurable_Run_Time_Mode := True; 183 end if; 184 185 -- Output copyright notice if full list mode 186 187 if (Verbose_Mode or Full_List) 188 and then (not Debug_Flag_7) 189 then 190 Write_Eol; 191 Write_Str ("GNAT "); 192 Write_Str (Gnat_Version_String); 193 Write_Str (" Copyright 1992-2004 Free Software Foundation, Inc."); 194 Write_Eol; 195 end if; 196 197 -- Before we do anything else, adjust certain global values for 198 -- debug switches which modify their normal natural settings. 199 200 if Debug_Flag_8 then 201 Ttypes.Bytes_Big_Endian := not Ttypes.Bytes_Big_Endian; 202 end if; 203 204 if Debug_Flag_M then 205 Targparm.OpenVMS_On_Target := True; 206 Hostparm.OpenVMS := True; 207 end if; 208 209 if Debug_Flag_FF then 210 Targparm.Frontend_Layout_On_Target := True; 211 end if; 212 213 -- We take the default exception mechanism into account 214 215 if Targparm.ZCX_By_Default_On_Target then 216 if Targparm.GCC_ZCX_Support_On_Target then 217 Exception_Mechanism := Back_End_ZCX_Exceptions; 218 else 219 Exception_Mechanism := Front_End_ZCX_Exceptions; 220 end if; 221 end if; 222 223 -- We take the command line exception mechanism into account 224 225 if Opt.Zero_Cost_Exceptions_Set then 226 if Opt.Zero_Cost_Exceptions_Val = False then 227 Exception_Mechanism := Front_End_Setjmp_Longjmp_Exceptions; 228 229 elsif Debug_Flag_XX then 230 Exception_Mechanism := Front_End_ZCX_Exceptions; 231 232 elsif Targparm.GCC_ZCX_Support_On_Target then 233 Exception_Mechanism := Back_End_ZCX_Exceptions; 234 235 elsif Targparm.Front_End_ZCX_Support_On_Target then 236 Exception_Mechanism := Front_End_ZCX_Exceptions; 237 238 else 239 Osint.Fail 240 ("Zero Cost Exceptions not supported on this target"); 241 end if; 242 end if; 243 244 -- Set proper status for overflow checks. We turn on overflow checks 245 -- if -gnatp was not specified, and either -gnato is set or the back 246 -- end takes care of overflow checks. Otherwise we suppress overflow 247 -- checks by default (since front end checks are expensive). 248 249 if not Opt.Suppress_Checks 250 and then (Opt.Enable_Overflow_Checks 251 or else 252 (Targparm.Backend_Divide_Checks_On_Target 253 and 254 Targparm.Backend_Overflow_Checks_On_Target)) 255 then 256 Suppress_Options (Overflow_Check) := False; 257 else 258 Suppress_Options (Overflow_Check) := True; 259 end if; 260 261 -- Check we have exactly one source file, this happens only in 262 -- the case where the driver is called directly, it cannot happen 263 -- when gnat1 is invoked from gcc in the normal case. 264 265 if Osint.Number_Of_Files /= 1 then 266 Usage; 267 Write_Eol; 268 Osint.Fail ("you must provide one source file"); 269 270 elsif Usage_Requested then 271 Usage; 272 end if; 273 274 Original_Operating_Mode := Operating_Mode; 275 Frontend; 276 Main_Unit_Node := Cunit (Main_Unit); 277 Main_Kind := Nkind (Unit (Main_Unit_Node)); 278 279 -- Check for suspicious or incorrect body present if we are doing 280 -- semantic checking. We omit this check in syntax only mode, because 281 -- in that case we do not know if we need a body or not. 282 283 if Operating_Mode /= Check_Syntax 284 and then 285 ((Main_Kind = N_Package_Declaration 286 and then not Body_Required (Main_Unit_Node)) 287 or else (Main_Kind = N_Generic_Package_Declaration 288 and then not Body_Required (Main_Unit_Node)) 289 or else Main_Kind = N_Package_Renaming_Declaration 290 or else Main_Kind = N_Subprogram_Renaming_Declaration 291 or else Nkind (Original_Node (Unit (Main_Unit_Node))) 292 in N_Generic_Instantiation) 293 then 294 declare 295 Sname : Unit_Name_Type := Unit_Name (Main_Unit); 296 Src_Ind : Source_File_Index; 297 Fname : File_Name_Type; 298 299 procedure Bad_Body (Msg : String); 300 -- Issue message for bad body found 301 302 procedure Bad_Body (Msg : String) is 303 begin 304 Error_Msg_N (Msg, Main_Unit_Node); 305 Error_Msg_Name_1 := Fname; 306 Error_Msg_N 307 ("remove incorrect body in file{!", Main_Unit_Node); 308 end Bad_Body; 309 310 begin 311 Sname := Unit_Name (Main_Unit); 312 313 -- If we do not already have a body name, then get the body 314 -- name (but how can we have a body name here ???) 315 316 if not Is_Body_Name (Sname) then 317 Sname := Get_Body_Name (Sname); 318 end if; 319 320 Fname := Get_File_Name (Sname, Subunit => False); 321 Src_Ind := Load_Source_File (Fname); 322 323 -- Case where body is present and it is not a subunit. Exclude 324 -- the subunit case, because it has nothing to do with the 325 -- package we are compiling. It is illegal for a child unit 326 -- and a subunit with the same expanded name (RM 10.2(9)) to 327 -- appear together in a partition, but there is nothing to 328 -- stop a compilation environment from having both, and the 329 -- test here simply allows that. If there is an attempt to 330 -- include both in a partition, this is diagnosed at bind time. 331 -- In Ada 83 mode this is not a warning case. 332 333 if Src_Ind /= No_Source_File 334 and then not Source_File_Is_Subunit (Src_Ind) 335 then 336 Error_Msg_Name_1 := Sname; 337 338 -- Ada 83 case of a package body being ignored. This is not 339 -- an error as far as the Ada 83 RM is concerned, but it is 340 -- almost certainly not what is wanted so output a warning. 341 -- Give this message only if there were no errors, since 342 -- otherwise it may be incorrect (we may have misinterpreted 343 -- a junk spec as not needing a body when it really does). 344 345 if Main_Kind = N_Package_Declaration 346 and then Ada_83 347 and then Operating_Mode = Generate_Code 348 and then Distribution_Stub_Mode /= Generate_Caller_Stub_Body 349 and then not Compilation_Errors 350 then 351 Error_Msg_N 352 ("package % does not require a body?!", Main_Unit_Node); 353 Error_Msg_Name_1 := Fname; 354 Error_Msg_N 355 ("body in file{?! will be ignored", Main_Unit_Node); 356 357 -- Ada 95 cases of a body file present when no body is 358 -- permitted. This we consider to be an error. 359 360 else 361 -- For generic instantiations, we never allow a body 362 363 if Nkind (Original_Node (Unit (Main_Unit_Node))) 364 in N_Generic_Instantiation 365 then 366 Bad_Body 367 ("generic instantiation for % does not allow a body"); 368 369 -- A library unit that is a renaming never allows a body 370 371 elsif Main_Kind in N_Renaming_Declaration then 372 Bad_Body 373 ("renaming declaration for % does not allow a body!"); 374 375 -- Remaining cases are packages and generic packages. 376 -- Here we only do the test if there are no previous 377 -- errors, because if there are errors, they may lead 378 -- us to incorrectly believe that a package does not 379 -- allow a body when in fact it does. 380 381 elsif not Compilation_Errors then 382 if Main_Kind = N_Package_Declaration then 383 Bad_Body ("package % does not allow a body!"); 384 385 elsif Main_Kind = N_Generic_Package_Declaration then 386 Bad_Body ("generic package % does not allow a body!"); 387 end if; 388 end if; 389 390 end if; 391 end if; 392 end; 393 end if; 394 395 -- Exit if compilation errors detected 396 397 if Compilation_Errors then 398 Treepr.Tree_Dump; 399 Sem_Ch13.Validate_Unchecked_Conversions; 400 Errout.Finalize; 401 Namet.Finalize; 402 403 -- Generate ALI file if specially requested 404 405 if Opt.Force_ALI_Tree_File then 406 Write_ALI (Object => False); 407 Tree_Gen; 408 end if; 409 410 Exit_Program (E_Errors); 411 end if; 412 413 -- Set Generate_Code on main unit and its spec. We do this even if 414 -- are not generating code, since Lib-Writ uses this to determine 415 -- which units get written in the ali file. 416 417 Set_Generate_Code (Main_Unit); 418 419 -- If we have a corresponding spec, then we need object 420 -- code for the spec unit as well 421 422 if Nkind (Unit (Main_Unit_Node)) in N_Unit_Body 423 and then not Acts_As_Spec (Main_Unit_Node) 424 then 425 Set_Generate_Code 426 (Get_Cunit_Unit_Number (Library_Unit (Main_Unit_Node))); 427 end if; 428 429 -- Case of no code required to be generated, exit indicating no error 430 431 if Original_Operating_Mode = Check_Syntax then 432 Treepr.Tree_Dump; 433 Errout.Finalize; 434 Tree_Gen; 435 Namet.Finalize; 436 Exit_Program (E_Success); 437 438 elsif Original_Operating_Mode = Check_Semantics then 439 Back_End_Mode := Declarations_Only; 440 441 -- All remaining cases are cases in which the user requested that code 442 -- be generated (i.e. no -gnatc or -gnats switch was used). Check if 443 -- we can in fact satisfy this request. 444 445 -- Cannot generate code if someone has turned off code generation 446 -- for any reason at all. We will try to figure out a reason below. 447 448 elsif Operating_Mode /= Generate_Code then 449 Back_End_Mode := Skip; 450 451 -- We can generate code for a subprogram body unless there were 452 -- missing subunits. Note that we always generate code for all 453 -- generic units (a change from some previous versions of GNAT). 454 455 elsif Main_Kind = N_Subprogram_Body 456 and then not Subunits_Missing 457 then 458 Back_End_Mode := Generate_Object; 459 460 -- We can generate code for a package body unless there are subunits 461 -- missing (note that we always generate code for generic units, which 462 -- is a change from some earlier versions of GNAT). 463 464 elsif Main_Kind = N_Package_Body 465 and then not Subunits_Missing 466 then 467 Back_End_Mode := Generate_Object; 468 469 -- We can generate code for a package declaration or a subprogram 470 -- declaration only if it does not required a body. 471 472 elsif (Main_Kind = N_Package_Declaration 473 or else 474 Main_Kind = N_Subprogram_Declaration) 475 and then 476 (not Body_Required (Main_Unit_Node) 477 or else 478 Distribution_Stub_Mode = Generate_Caller_Stub_Body) 479 then 480 Back_End_Mode := Generate_Object; 481 482 -- We can generate code for a generic package declaration of a generic 483 -- subprogram declaration only if does not require a body. 484 485 elsif (Main_Kind = N_Generic_Package_Declaration 486 or else 487 Main_Kind = N_Generic_Subprogram_Declaration) 488 and then not Body_Required (Main_Unit_Node) 489 then 490 Back_End_Mode := Generate_Object; 491 492 -- Compilation units that are renamings do not require bodies, 493 -- so we can generate code for them. 494 495 elsif Main_Kind = N_Package_Renaming_Declaration 496 or else Main_Kind = N_Subprogram_Renaming_Declaration 497 then 498 Back_End_Mode := Generate_Object; 499 500 -- Compilation units that are generic renamings do not require bodies 501 -- so we can generate code for them. 502 503 elsif Main_Kind in N_Generic_Renaming_Declaration then 504 Back_End_Mode := Generate_Object; 505 506 -- In all other cases (specs which have bodies, generics, and bodies 507 -- where subunits are missing), we cannot generate code and we generate 508 -- a warning message. Note that generic instantiations are gone at this 509 -- stage since they have been replaced by their instances. 510 511 else 512 Back_End_Mode := Skip; 513 end if; 514 515 -- At this stage Call_Back_End is set to indicate if the backend 516 -- should be called to generate code. If it is not set, then code 517 -- generation has been turned off, even though code was requested 518 -- by the original command. This is not an error from the user 519 -- point of view, but it is an error from the point of view of 520 -- the gcc driver, so we must exit with an error status. 521 522 -- We generate an informative message (from the gcc point of view, 523 -- it is an error message, but from the users point of view this 524 -- is not an error, just a consequence of compiling something that 525 -- cannot generate code). 526 527 if Back_End_Mode = Skip then 528 Write_Str ("cannot generate code for "); 529 Write_Str ("file "); 530 Write_Name (Unit_File_Name (Main_Unit)); 531 532 if Subunits_Missing then 533 Write_Str (" (missing subunits)"); 534 Write_Eol; 535 Write_Str ("to check parent unit"); 536 537 elsif Main_Kind = N_Subunit then 538 Write_Str (" (subunit)"); 539 Write_Eol; 540 Write_Str ("to check subunit"); 541 542 elsif Main_Kind = N_Subprogram_Declaration then 543 Write_Str (" (subprogram spec)"); 544 Write_Eol; 545 Write_Str ("to check subprogram spec"); 546 547 -- Generic package body in GNAT implementation mode 548 549 elsif Main_Kind = N_Package_Body and then GNAT_Mode then 550 Write_Str (" (predefined generic)"); 551 Write_Eol; 552 Write_Str ("to check predefined generic"); 553 554 -- Only other case is a package spec 555 556 else 557 Write_Str (" (package spec)"); 558 Write_Eol; 559 Write_Str ("to check package spec"); 560 end if; 561 562 Write_Str (" for errors, use "); 563 564 if Hostparm.OpenVMS then 565 Write_Str ("/NOLOAD"); 566 else 567 Write_Str ("-gnatc"); 568 end if; 569 570 Write_Eol; 571 572 Sem_Ch13.Validate_Unchecked_Conversions; 573 Errout.Finalize; 574 Treepr.Tree_Dump; 575 Tree_Gen; 576 Write_ALI (Object => False); 577 Namet.Finalize; 578 579 -- Exit program with error indication, to kill object file 580 581 Exit_Program (E_No_Code); 582 end if; 583 584 -- In -gnatc mode, we only do annotation if -gnatt or -gnatR is also 585 -- set as indicated by Back_Annotate_Rep_Info being set to True. 586 587 -- We don't call for annotations on a subunit, because to process those 588 -- the back-end requires that the parent(s) be properly compiled. 589 590 -- Annotation is also suppressed in the case of compiling for 591 -- the Java VM, since representations are largely symbolic there. 592 593 if Back_End_Mode = Declarations_Only 594 and then (not (Back_Annotate_Rep_Info or Debug_Flag_AA) 595 or else Main_Kind = N_Subunit 596 or else Hostparm.Java_VM) 597 then 598 Sem_Ch13.Validate_Unchecked_Conversions; 599 Errout.Finalize; 600 Write_ALI (Object => False); 601 Tree_Dump; 602 Tree_Gen; 603 Namet.Finalize; 604 return; 605 end if; 606 607 -- Ensure that we properly register a dependency on system.ads, 608 -- since even if we do not semantically depend on this, Targparm 609 -- has read system parameters from the system.ads file. 610 611 Lib.Writ.Ensure_System_Dependency; 612 613 -- Add dependencies, if any, on preprocessing data file and on 614 -- preprocessing definition file(s). 615 616 Prepcomp.Add_Dependencies; 617 618 -- Back end needs to explicitly unlock tables it needs to touch 619 620 Atree.Lock; 621 Elists.Lock; 622 Fname.UF.Lock; 623 Inline.Lock; 624 Lib.Lock; 625 Nlists.Lock; 626 Sem.Lock; 627 Sinput.Lock; 628 Namet.Lock; 629 Stringt.Lock; 630 631 -- Here we call the back end to generate the output code 632 633 Back_End.Call_Back_End (Back_End_Mode); 634 635 -- Once the backend is complete, we unlock the names table. This 636 -- call allows a few extra entries, needed for example for the file 637 -- name for the library file output. 638 639 Namet.Unlock; 640 641 -- Validate unchecked conversions (using the values for size 642 -- and alignment annotated by the backend where possible). 643 644 Sem_Ch13.Validate_Unchecked_Conversions; 645 646 -- Now we complete output of errors, rep info and the tree info. 647 -- These are delayed till now, since it is perfectly possible for 648 -- gigi to generate errors, modify the tree (in particular by setting 649 -- flags indicating that elaboration is required, and also to back 650 -- annotate representation information for List_Rep_Info. 651 652 Errout.Finalize; 653 List_Rep_Info; 654 655 -- Only write the library if the backend did not generate any error 656 -- messages. Otherwise signal errors to the driver program so that 657 -- there will be no attempt to generate an object file. 658 659 if Compilation_Errors then 660 Treepr.Tree_Dump; 661 Exit_Program (E_Errors); 662 end if; 663 664 Write_ALI (Object => (Back_End_Mode = Generate_Object)); 665 666 -- Generate the ASIS tree after writing the ALI file, since in 667 -- ASIS mode, Write_ALI may in fact result in further tree 668 -- decoration from the original tree file. Note that we dump 669 -- the tree just before generating it, so that the dump will 670 -- exactly reflect what is written out. 671 672 Treepr.Tree_Dump; 673 Tree_Gen; 674 675 -- Finalize name table and we are all done 676 677 Namet.Finalize; 678 679 exception 680 -- Handle fatal internal compiler errors 681 682 when System.Assertions.Assert_Failure => 683 Comperr.Compiler_Abort ("Assert_Failure"); 684 685 when Constraint_Error => 686 Comperr.Compiler_Abort ("Constraint_Error"); 687 688 when Program_Error => 689 Comperr.Compiler_Abort ("Program_Error"); 690 691 when Storage_Error => 692 693 -- Assume this is a bug. If it is real, the message will in 694 -- any case say Storage_Error, giving a strong hint! 695 696 Comperr.Compiler_Abort ("Storage_Error"); 697 end; 698 699-- The outer exception handles an unrecoverable error 700 701exception 702 when Unrecoverable_Error => 703 Errout.Finalize; 704 705 Set_Standard_Error; 706 Write_Str ("compilation abandoned"); 707 Write_Eol; 708 709 Set_Standard_Output; 710 Source_Dump; 711 Tree_Dump; 712 Exit_Program (E_Errors); 713 714end Gnat1drv; 715