gcc/ada/gnat1drv.adb

   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-2009, 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
  26 with Atree;    use Atree;
  27 with Back_End; use Back_End;
  28 with Comperr;
  29 with Csets;    use Csets;
  30 with Debug;    use Debug;
  31 with Elists;
  32 with Errout;   use Errout;
  33 with Fmap;
  34 with Fname;    use Fname;
  35 with Fname.UF; use Fname.UF;
  36 with Frontend;
  37 with Gnatvsn;  use Gnatvsn;
  38 with Hostparm;
  39 with Inline;
  40 with Lib;      use Lib;
  41 with Lib.Writ; use Lib.Writ;
  42 with Lib.Xref;
  43 with Namet;    use Namet;
  44 with Nlists;
  45 with Opt;      use Opt;
  46 with Osint;    use Osint;
  47 with Output;   use Output;
  48 with Prepcomp;
  49 with Repinfo;  use Repinfo;
  50 with Restrict;
  51 with Rtsfind;
  52 with Sem;
  53 with Sem_Ch8;
  54 with Sem_Ch12;
  55 with Sem_Ch13;
  56 with Sem_Elim;
  57 with Sem_Eval;
  58 with Sem_Type;
  59 with Sinfo;    use Sinfo;
  60 with Sinput.L; use Sinput.L;
  61 with Snames;
  62 with Sprint;   use Sprint;
  63 with Stringt;
  64 with Targparm; use Targparm;
  65 with Tree_Gen;
  66 with Treepr;   use Treepr;
  67 with Ttypes;
  68 with Types;    use Types;
  69 with Uintp;    use Uintp;
  70 with Uname;    use Uname;
  71 with Urealp;
  72 with Usage;
  73
  74 with System.Assertions;
  75
  76 procedure Gnat1drv is
  77    Main_Unit_Node : Node_Id;
  78    --  Compilation unit node for main unit
  79
  80    Main_Kind : Node_Kind;
  81    --  Kind of main compilation unit node
  82
  83    Back_End_Mode : Back_End.Back_End_Mode_Type;
  84    --  Record back end mode
  85
  86    procedure Adjust_Global_Switches;
  87    --  There are various interactions between front end switch settings,
  88    --  including debug switch settings and target dependent parameters.
  89    --  This procedure takes care of properly handling these interactions.
  90    --  We do it after scanning out all the switches, that way we are not
  91    --  depending on the order in which switches appear.
  92
  93    procedure Check_Bad_Body;
  94    --  Called to check if the unit we are compiling has a bad body
  95
  96    procedure Check_Rep_Info;
  97    --  Called when we are not generating code, to check if -gnatR was requested
  98    --  and if so, explain that we will not be honoring the request.
  99
 100    procedure Check_Library_Items;
 101    --  For debugging -- checks the behavior of Walk_Library_Items
 102    pragma Warnings (Off, Check_Library_Items);
 103    --  In case the call below is commented out
 104
 105    ----------------------------
 106    -- Adjust_Global_Switches --
 107    ----------------------------
 108
 109    procedure Adjust_Global_Switches is
 110    begin
 111
 112       --  Set ASIS mode if -gnatt and -gnatc are set
 113
 114       if Operating_Mode = Check_Semantics and then Tree_Output then
 115          ASIS_Mode := True;
 116
 117          --  Turn off inlining in ASIS mode, since ASIS cannot handle the extra
 118          --  information in the trees caused by inlining being active.
 119
 120          --  More specifically, the tree seems to malformed from the ASIS point
 121          --  of view if -gnatc and -gnatn appear together ???
 122
 123          Inline_Active := False;
 124
 125          --  Turn off inspector mode in ASIS mode. For reasons that need
 126          --  clearer documentation, Inspector cannot function in this mode ???
 127
 128          Inspector_Mode := False;
 129       end if;
 130
 131       --  Inspeector mode requires back-end rep info and also needs to disable
 132       --  front-end inlining (but -gnatn does not need to be disabled).
 133
 134       if Inspector_Mode then
 135          Back_Annotate_Rep_Info := True;
 136          Front_End_Inlining := False;
 137       end if;
 138
 139       --  Set Configurable_Run_Time mode if system.ads flag set
 140
 141       if Targparm.Configurable_Run_Time_On_Target or Debug_Flag_YY then
 142          Configurable_Run_Time_Mode := True;
 143       end if;
 144
 145       --  Set -gnatR3m mode if debug flag A set
 146
 147       if Debug_Flag_AA then
 148          Back_Annotate_Rep_Info := True;
 149          List_Representation_Info := 1;
 150          List_Representation_Info_Mechanisms := True;
 151       end if;
 152
 153       --  Force Target_Strict_Alignment true if debug flag -gnatd.a is set
 154
 155       if Debug_Flag_Dot_A then
 156          Ttypes.Target_Strict_Alignment := True;
 157       end if;
 158
 159       --  Disable static allocation of dispatch tables if -gnatd.t or if layout
 160       --  is enabled. The front end's layout phase currently treats types that
 161       --  have discriminant-dependent arrays as not being static even when a
 162       --  discriminant constraint on the type is static, and this leads to
 163       --  problems with subtypes of type Ada.Tags.Dispatch_Table_Wrapper. ???
 164
 165       if Debug_Flag_Dot_T or else Frontend_Layout_On_Target then
 166          Static_Dispatch_Tables := False;
 167       end if;
 168
 169       --  Flip endian mode if -gnatd8 set
 170
 171       if Debug_Flag_8 then
 172          Ttypes.Bytes_Big_Endian := not Ttypes.Bytes_Big_Endian;
 173       end if;
 174
 175       --  Deal with forcing OpenVMS switches True if debug flag M is set, but
 176       --  record the setting of Targparm.Open_VMS_On_Target in True_VMS_Target
 177       --  before doing this, so we know if we are in real openVMS or not!
 178
 179       Opt.True_VMS_Target := Targparm.OpenVMS_On_Target;
 180
 181       if Debug_Flag_M then
 182          Targparm.OpenVMS_On_Target := True;
 183          Hostparm.OpenVMS := True;
 184       end if;
 185
 186       --  Activate front end layout if debug flag -gnatdF is set
 187
 188       if Debug_Flag_FF then
 189          Targparm.Frontend_Layout_On_Target := True;
 190       end if;
 191
 192       --  Set and check exception mechnism
 193
 194       if Targparm.ZCX_By_Default_On_Target then
 195          if Targparm.GCC_ZCX_Support_On_Target then
 196             Exception_Mechanism := Back_End_Exceptions;
 197          else
 198             Osint.Fail ("Zero Cost Exceptions not supported on this target");
 199          end if;
 200       end if;
 201
 202       --  Set proper status for overflow checks. We turn on overflow checks
 203       --  if -gnatp was not specified, and either -gnato is set or the back
 204       --  end takes care of overflow checks. Otherwise we suppress overflow
 205       --  checks by default (since front end checks are expensive).
 206
 207       if not Opt.Suppress_Checks
 208         and then (Opt.Enable_Overflow_Checks
 209                     or else
 210                       (Targparm.Backend_Divide_Checks_On_Target
 211                         and
 212                        Targparm.Backend_Overflow_Checks_On_Target))
 213       then
 214          Suppress_Options (Overflow_Check) := False;
 215       else
 216          Suppress_Options (Overflow_Check) := True;
 217       end if;
 218    end Adjust_Global_Switches;
 219
 220    --------------------
 221    -- Check_Bad_Body --
 222    --------------------
 223
 224    procedure Check_Bad_Body is
 225       Sname   : Unit_Name_Type;
 226       Src_Ind : Source_File_Index;
 227       Fname   : File_Name_Type;
 228
 229       procedure Bad_Body_Error (Msg : String);
 230       --  Issue message for bad body found
 231
 232       --------------------
 233       -- Bad_Body_Error --
 234       --------------------
 235
 236       procedure Bad_Body_Error (Msg : String) is
 237       begin
 238          Error_Msg_N (Msg, Main_Unit_Node);
 239          Error_Msg_File_1 := Fname;
 240          Error_Msg_N ("remove incorrect body in file{!", Main_Unit_Node);
 241       end Bad_Body_Error;
 242
 243       --  Start of processing for Check_Bad_Body
 244
 245    begin
 246       --  Nothing to do if we are only checking syntax, because we don't know
 247       --  enough to know if we require or forbid a body in this case.
 248
 249       if Operating_Mode = Check_Syntax then
 250          return;
 251       end if;
 252
 253       --  Check for body not allowed
 254
 255       if (Main_Kind = N_Package_Declaration
 256            and then not Body_Required (Main_Unit_Node))
 257         or else (Main_Kind = N_Generic_Package_Declaration
 258                   and then not Body_Required (Main_Unit_Node))
 259         or else Main_Kind = N_Package_Renaming_Declaration
 260         or else Main_Kind = N_Subprogram_Renaming_Declaration
 261         or else Nkind (Original_Node (Unit (Main_Unit_Node)))
 262                          in N_Generic_Instantiation
 263       then
 264          Sname := Unit_Name (Main_Unit);
 265
 266          --  If we do not already have a body name, then get the body name
 267          --  (but how can we have a body name here ???)
 268
 269          if not Is_Body_Name (Sname) then
 270             Sname := Get_Body_Name (Sname);
 271          end if;
 272
 273          Fname := Get_File_Name (Sname, Subunit => False);
 274          Src_Ind := Load_Source_File (Fname);
 275
 276          --  Case where body is present and it is not a subunit. Exclude
 277          --  the subunit case, because it has nothing to do with the
 278          --  package we are compiling. It is illegal for a child unit and a
 279          --  subunit with the same expanded name (RM 10.2(9)) to appear
 280          --  together in a partition, but there is nothing to stop a
 281          --  compilation environment from having both, and the test here
 282          --  simply allows that. If there is an attempt to include both in
 283          --  a partition, this is diagnosed at bind time. In Ada 83 mode
 284          --  this is not a warning case.
 285
 286          --  Note: if weird file names are being used, we can have
 287          --  situation where the file name that supposedly contains body,
 288          --  in fact contains a spec, or we can't tell what it contains.
 289          --  Skip the error message in these cases.
 290
 291          --  Also ignore body that is nothing but pragma No_Body; (that's the
 292          --  whole point of this pragma, to be used this way and to cause the
 293          --  body file to be ignored in this context).
 294
 295          if Src_Ind /= No_Source_File
 296            and then Get_Expected_Unit_Type (Fname) = Expect_Body
 297            and then not Source_File_Is_Subunit (Src_Ind)
 298            and then not Source_File_Is_No_Body (Src_Ind)
 299          then
 300             Errout.Finalize (Last_Call => False);
 301
 302             Error_Msg_Unit_1 := Sname;
 303
 304             --  Ada 83 case of a package body being ignored. This is not an
 305             --  error as far as the Ada 83 RM is concerned, but it is almost
 306             --  certainly not what is wanted so output a warning. Give this
 307             --  message only if there were no errors, since otherwise it may
 308             --  be incorrect (we may have misinterpreted a junk spec as not
 309             --  needing a body when it really does).
 310
 311             if Main_Kind = N_Package_Declaration
 312               and then Ada_Version = Ada_83
 313               and then Operating_Mode = Generate_Code
 314               and then Distribution_Stub_Mode /= Generate_Caller_Stub_Body
 315               and then not Compilation_Errors
 316             then
 317                Error_Msg_N
 318                  ("package $$ does not require a body?", Main_Unit_Node);
 319                Error_Msg_File_1 := Fname;
 320                Error_Msg_N ("body in file{? will be ignored", Main_Unit_Node);
 321
 322                --  Ada 95 cases of a body file present when no body is
 323                --  permitted. This we consider to be an error.
 324
 325             else
 326                --  For generic instantiations, we never allow a body
 327
 328                if Nkind (Original_Node (Unit (Main_Unit_Node)))
 329                in N_Generic_Instantiation
 330                then
 331                   Bad_Body_Error
 332                     ("generic instantiation for $$ does not allow a body");
 333
 334                   --  A library unit that is a renaming never allows a body
 335
 336                elsif Main_Kind in N_Renaming_Declaration then
 337                   Bad_Body_Error
 338                     ("renaming declaration for $$ does not allow a body!");
 339
 340                   --  Remaining cases are packages and generic packages. Here
 341                   --  we only do the test if there are no previous errors,
 342                   --  because if there are errors, they may lead us to
 343                   --  incorrectly believe that a package does not allow a body
 344                   --  when in fact it does.
 345
 346                elsif not Compilation_Errors then
 347                   if Main_Kind = N_Package_Declaration then
 348                      Bad_Body_Error
 349                        ("package $$ does not allow a body!");
 350
 351                   elsif Main_Kind = N_Generic_Package_Declaration then
 352                      Bad_Body_Error
 353                        ("generic package $$ does not allow a body!");
 354                   end if;
 355                end if;
 356
 357             end if;
 358          end if;
 359       end if;
 360    end Check_Bad_Body;
 361
 362    --------------------
 363    -- Check_Rep_Info --
 364    --------------------
 365
 366    procedure Check_Rep_Info is
 367    begin
 368       if List_Representation_Info /= 0
 369         or else List_Representation_Info_Mechanisms
 370       then
 371          Set_Standard_Error;
 372          Write_Eol;
 373          Write_Str
 374            ("cannot generate representation information, no code generated");
 375          Write_Eol;
 376          Write_Eol;
 377          Set_Standard_Output;
 378       end if;
 379    end Check_Rep_Info;
 380
 381    -------------------------
 382    -- Check_Library_Items --
 383    -------------------------
 384
 385    --  Walk_Library_Items has plenty of assertions, so all we need to do is
 386    --  call it, just for these assertions, not actually doing anything else.
 387
 388    procedure Check_Library_Items is
 389
 390       procedure Action (Item : Node_Id);
 391       --  Action passed to Walk_Library_Items to do nothing
 392
 393       ------------
 394       -- Action --
 395       ------------
 396
 397       procedure Action (Item : Node_Id) is
 398       begin
 399          null;
 400       end Action;
 401
 402       procedure Walk is new Sem.Walk_Library_Items (Action);
 403
 404    --  Start of processing for Check_Library_Items
 405
 406    begin
 407       Walk;
 408    end Check_Library_Items;
 409
 410 --  Start of processing for Gnat1drv
 411
 412 begin
 413    --  This inner block is set up to catch assertion errors and constraint
 414    --  errors. Since the code for handling these errors can cause another
 415    --  exception to be raised (namely Unrecoverable_Error), we need two
 416    --  nested blocks, so that the outer one handles unrecoverable error.
 417
 418    begin
 419       --  Lib.Initialize need to be called before Scan_Compiler_Arguments,
 420       --  because it initializes a table filled by Scan_Compiler_Arguments.
 421
 422       Osint.Initialize;
 423       Fmap.Reset_Tables;
 424       Lib.Initialize;
 425       Lib.Xref.Initialize;
 426       Scan_Compiler_Arguments;
 427       Osint.Add_Default_Search_Dirs;
 428
 429       Nlists.Initialize;
 430       Sinput.Initialize;
 431       Sem.Initialize;
 432       Csets.Initialize;
 433       Uintp.Initialize;
 434       Urealp.Initialize;
 435       Errout.Initialize;
 436       Namet.Initialize;
 437       Snames.Initialize;
 438       Stringt.Initialize;
 439       Inline.Initialize;
 440       Sem_Ch8.Initialize;
 441       Sem_Ch12.Initialize;
 442       Sem_Ch13.Initialize;
 443       Sem_Elim.Initialize;
 444       Sem_Eval.Initialize;
 445       Sem_Type.Init_Interp_Tables;
 446
 447       --  Acquire target parameters from system.ads (source of package System)
 448
 449       declare
 450          use Sinput;
 451
 452          S : Source_File_Index;
 453          N : File_Name_Type;
 454
 455       begin
 456          Name_Buffer (1 .. 10) := "system.ads";
 457          Name_Len := 10;
 458          N := Name_Find;
 459          S := Load_Source_File (N);
 460
 461          if S = No_Source_File then
 462             Write_Line
 463               ("fatal error, run-time library not installed correctly");
 464             Write_Line
 465               ("cannot locate file system.ads");
 466             raise Unrecoverable_Error;
 467
 468          --  Remember source index of system.ads (which was read successfully)
 469
 470          else
 471             System_Source_File_Index := S;
 472          end if;
 473
 474          Targparm.Get_Target_Parameters
 475            (System_Text  => Source_Text  (S),
 476             Source_First => Source_First (S),
 477             Source_Last  => Source_Last  (S));
 478
 479          --  Acquire configuration pragma information from Targparm
 480
 481          Restrict.Restrictions := Targparm.Restrictions_On_Target;
 482       end;
 483
 484       Adjust_Global_Switches;
 485
 486       --  Output copyright notice if full list mode unless we have a list
 487       --  file, in which case we defer this so that it is output in the file
 488
 489       if (Verbose_Mode or else (Full_List and then Full_List_File_Name = null))
 490         and then not Debug_Flag_7
 491       then
 492          Write_Eol;
 493          Write_Str ("GNAT ");
 494          Write_Str (Gnat_Version_String);
 495          Write_Eol;
 496          Write_Str ("Copyright 1992-" &
 497                     Current_Year &
 498                     ", Free Software Foundation, Inc.");
 499          Write_Eol;
 500       end if;
 501
 502       --  Check we do not have more than one source file, this happens only in
 503       --  the case where the driver is called directly, it cannot happen when
 504       --  gnat1 is invoked from gcc in the normal case.
 505
 506       if Osint.Number_Of_Files /= 1 then
 507          Usage;
 508          Write_Eol;
 509          Osint.Fail ("you must provide one source file");
 510
 511       elsif Usage_Requested then
 512          Usage;
 513       end if;
 514
 515       Original_Operating_Mode := Operating_Mode;
 516       Frontend;
 517
 518       --  Exit with errors if the main source could not be parsed
 519
 520       if Sinput.Main_Source_File = No_Source_File then
 521          Errout.Finalize (Last_Call => True);
 522          Errout.Output_Messages;
 523          Exit_Program (E_Errors);
 524       end if;
 525
 526       Main_Unit_Node := Cunit (Main_Unit);
 527       Main_Kind := Nkind (Unit (Main_Unit_Node));
 528       Check_Bad_Body;
 529
 530       --  Exit if compilation errors detected
 531
 532       Errout.Finalize (Last_Call => False);
 533
 534       if Compilation_Errors then
 535          Treepr.Tree_Dump;
 536          Sem_Ch13.Validate_Unchecked_Conversions;
 537          Sem_Ch13.Validate_Address_Clauses;
 538          Errout.Output_Messages;
 539          Namet.Finalize;
 540
 541          --  Generate ALI file if specially requested
 542
 543          if Opt.Force_ALI_Tree_File then
 544             Write_ALI (Object => False);
 545             Tree_Gen;
 546          end if;
 547
 548          Errout.Finalize (Last_Call => True);
 549          Exit_Program (E_Errors);
 550       end if;
 551
 552       --  Set Generate_Code on main unit and its spec. We do this even if are
 553       --  not generating code, since Lib-Writ uses this to determine which
 554       --  units get written in the ali file.
 555
 556       Set_Generate_Code (Main_Unit);
 557
 558       --  If we have a corresponding spec, and it comes from source
 559       --  or it is not a generated spec for a child subprogram body,
 560       --  then we need object code for the spec unit as well.
 561
 562       if Nkind (Unit (Main_Unit_Node)) in N_Unit_Body
 563         and then not Acts_As_Spec (Main_Unit_Node)
 564       then
 565          if Nkind (Unit (Main_Unit_Node)) = N_Subprogram_Body
 566            and then not Comes_From_Source (Library_Unit (Main_Unit_Node))
 567          then
 568             null;
 569          else
 570             Set_Generate_Code
 571               (Get_Cunit_Unit_Number (Library_Unit (Main_Unit_Node)));
 572          end if;
 573       end if;
 574
 575       --  Case of no code required to be generated, exit indicating no error
 576
 577       if Original_Operating_Mode = Check_Syntax then
 578          Treepr.Tree_Dump;
 579          Errout.Finalize (Last_Call => True);
 580          Errout.Output_Messages;
 581          Tree_Gen;
 582          Namet.Finalize;
 583          Check_Rep_Info;
 584
 585          --  Use a goto instead of calling Exit_Program so that finalization
 586          --  occurs normally.
 587
 588          goto End_Of_Program;
 589
 590       elsif Original_Operating_Mode = Check_Semantics then
 591          Back_End_Mode := Declarations_Only;
 592
 593       --  All remaining cases are cases in which the user requested that code
 594       --  be generated (i.e. no -gnatc or -gnats switch was used). Check if
 595       --  we can in fact satisfy this request.
 596
 597       --  Cannot generate code if someone has turned off code generation for
 598       --  any reason at all. We will try to figure out a reason below.
 599
 600       elsif Operating_Mode /= Generate_Code then
 601          Back_End_Mode := Skip;
 602
 603       --  We can generate code for a subprogram body unless there were missing
 604       --  subunits. Note that we always generate code for all generic units (a
 605       --  change from some previous versions of GNAT).
 606
 607       elsif Main_Kind = N_Subprogram_Body
 608         and then not Subunits_Missing
 609       then
 610          Back_End_Mode := Generate_Object;
 611
 612       --  We can generate code for a package body unless there are subunits
 613       --  missing (note that we always generate code for generic units, which
 614       --  is a change from some earlier versions of GNAT).
 615
 616       elsif Main_Kind = N_Package_Body
 617         and then not Subunits_Missing
 618       then
 619          Back_End_Mode := Generate_Object;
 620
 621       --  We can generate code for a package declaration or a subprogram
 622       --  declaration only if it does not required a body.
 623
 624       elsif (Main_Kind = N_Package_Declaration
 625                or else
 626              Main_Kind = N_Subprogram_Declaration)
 627         and then
 628           (not Body_Required (Main_Unit_Node)
 629              or else
 630            Distribution_Stub_Mode = Generate_Caller_Stub_Body)
 631       then
 632          Back_End_Mode := Generate_Object;
 633
 634       --  We can generate code for a generic package declaration of a generic
 635       --  subprogram declaration only if does not require a body.
 636
 637       elsif (Main_Kind = N_Generic_Package_Declaration
 638                or else
 639              Main_Kind = N_Generic_Subprogram_Declaration)
 640         and then not Body_Required (Main_Unit_Node)
 641       then
 642          Back_End_Mode := Generate_Object;
 643
 644       --  Compilation units that are renamings do not require bodies,
 645       --  so we can generate code for them.
 646
 647       elsif Main_Kind = N_Package_Renaming_Declaration
 648         or else Main_Kind = N_Subprogram_Renaming_Declaration
 649       then
 650          Back_End_Mode := Generate_Object;
 651
 652       --  Compilation units that are generic renamings do not require bodies
 653       --  so we can generate code for them.
 654
 655       elsif Main_Kind in N_Generic_Renaming_Declaration then
 656          Back_End_Mode := Generate_Object;
 657
 658       --  In all other cases (specs which have bodies, generics, and bodies
 659       --  where subunits are missing), we cannot generate code and we generate
 660       --  a warning message. Note that generic instantiations are gone at this
 661       --  stage since they have been replaced by their instances.
 662
 663       else
 664          Back_End_Mode := Skip;
 665       end if;
 666
 667       --  At this stage Back_End_Mode is set to indicate if the backend should
 668       --  be called to generate code. If it is Skip, then code generation has
 669       --  been turned off, even though code was requested by the original
 670       --  command. This is not an error from the user point of view, but it is
 671       --  an error from the point of view of the gcc driver, so we must exit
 672       --  with an error status.
 673
 674       --  We generate an informative message (from the gcc point of view, it
 675       --  is an error message, but from the users point of view this is not an
 676       --  error, just a consequence of compiling something that cannot
 677       --  generate code).
 678
 679       if Back_End_Mode = Skip then
 680          Set_Standard_Error;
 681          Write_Str ("cannot generate code for ");
 682          Write_Str ("file ");
 683          Write_Name (Unit_File_Name (Main_Unit));
 684
 685          if Subunits_Missing then
 686             Write_Str (" (missing subunits)");
 687             Write_Eol;
 688             Write_Str ("to check parent unit");
 689
 690          elsif Main_Kind = N_Subunit then
 691             Write_Str (" (subunit)");
 692             Write_Eol;
 693             Write_Str ("to check subunit");
 694
 695          elsif Main_Kind = N_Subprogram_Declaration then
 696             Write_Str (" (subprogram spec)");
 697             Write_Eol;
 698             Write_Str ("to check subprogram spec");
 699
 700          --  Generic package body in GNAT implementation mode
 701
 702          elsif Main_Kind = N_Package_Body and then GNAT_Mode then
 703             Write_Str (" (predefined generic)");
 704             Write_Eol;
 705             Write_Str ("to check predefined generic");
 706
 707          --  Only other case is a package spec
 708
 709          else
 710             Write_Str (" (package spec)");
 711             Write_Eol;
 712             Write_Str ("to check package spec");
 713          end if;
 714
 715          Write_Str (" for errors, use ");
 716
 717          if Hostparm.OpenVMS then
 718             Write_Str ("/NOLOAD");
 719          else
 720             Write_Str ("-gnatc");
 721          end if;
 722
 723          Write_Eol;
 724          Set_Standard_Output;
 725
 726          Sem_Ch13.Validate_Unchecked_Conversions;
 727          Sem_Ch13.Validate_Address_Clauses;
 728          Errout.Finalize (Last_Call => True);
 729          Errout.Output_Messages;
 730          Treepr.Tree_Dump;
 731          Tree_Gen;
 732          Write_ALI (Object => False);
 733          Namet.Finalize;
 734          Check_Rep_Info;
 735
 736          --  Exit program with error indication, to kill object file
 737
 738          Exit_Program (E_No_Code);
 739       end if;
 740
 741       --  In -gnatc mode, we only do annotation if -gnatt or -gnatR is also
 742       --  set as indicated by Back_Annotate_Rep_Info being set to True.
 743
 744       --  We don't call for annotations on a subunit, because to process those
 745       --  the back-end requires that the parent(s) be properly compiled.
 746
 747       --  Annotation is suppressed for targets where front-end layout is
 748       --  enabled, because the front end determines representations.
 749
 750       --  Annotation is also suppressed in the case of compiling for
 751       --  a VM, since representations are largely symbolic there.
 752
 753       if Back_End_Mode = Declarations_Only
 754         and then (not Back_Annotate_Rep_Info
 755                    or else Main_Kind = N_Subunit
 756                    or else Targparm.Frontend_Layout_On_Target
 757                    or else Targparm.VM_Target /= No_VM)
 758       then
 759          Sem_Ch13.Validate_Unchecked_Conversions;
 760          Sem_Ch13.Validate_Address_Clauses;
 761          Errout.Finalize (Last_Call => True);
 762          Errout.Output_Messages;
 763          Write_ALI (Object => False);
 764          Tree_Dump;
 765          Tree_Gen;
 766          Namet.Finalize;
 767          Check_Rep_Info;
 768          return;
 769       end if;
 770
 771       --  Ensure that we properly register a dependency on system.ads, since
 772       --  even if we do not semantically depend on this, Targparm has read
 773       --  system parameters from the system.ads file.
 774
 775       Lib.Writ.Ensure_System_Dependency;
 776
 777       --  Add dependencies, if any, on preprocessing data file and on
 778       --  preprocessing definition file(s).
 779
 780       Prepcomp.Add_Dependencies;
 781
 782       --  Back end needs to explicitly unlock tables it needs to touch
 783
 784       Atree.Lock;
 785       Elists.Lock;
 786       Fname.UF.Lock;
 787       Inline.Lock;
 788       Lib.Lock;
 789       Nlists.Lock;
 790       Sem.Lock;
 791       Sinput.Lock;
 792       Namet.Lock;
 793       Stringt.Lock;
 794
 795       --  ???Check_Library_Items under control of a debug flag, because it
 796       --  currently does not work if the -gnatn switch (back end inlining) is
 797       --  used.
 798
 799       if Debug_Flag_Dot_WW then
 800          Check_Library_Items;
 801       end if;
 802
 803       --  Here we call the back end to generate the output code
 804
 805       Generating_Code := True;
 806       Back_End.Call_Back_End (Back_End_Mode);
 807
 808       --  Once the backend is complete, we unlock the names table. This call
 809       --  allows a few extra entries, needed for example for the file name for
 810       --  the library file output.
 811
 812       Namet.Unlock;
 813
 814       --  Validate unchecked conversions (using the values for size and
 815       --  alignment annotated by the backend where possible).
 816
 817       Sem_Ch13.Validate_Unchecked_Conversions;
 818
 819       --  Validate address clauses (again using alignment values annotated
 820       --  by the backend where possible).
 821
 822       Sem_Ch13.Validate_Address_Clauses;
 823
 824       --  Now we complete output of errors, rep info and the tree info. These
 825       --  are delayed till now, since it is perfectly possible for gigi to
 826       --  generate errors, modify the tree (in particular by setting flags
 827       --  indicating that elaboration is required, and also to back annotate
 828       --  representation information for List_Rep_Info.
 829
 830       Errout.Finalize (Last_Call => True);
 831       Errout.Output_Messages;
 832       List_Rep_Info;
 833
 834       --  Only write the library if the backend did not generate any error
 835       --  messages. Otherwise signal errors to the driver program so that
 836       --  there will be no attempt to generate an object file.
 837
 838       if Compilation_Errors then
 839          Treepr.Tree_Dump;
 840          Exit_Program (E_Errors);
 841       end if;
 842
 843       Write_ALI (Object => (Back_End_Mode = Generate_Object));
 844
 845       --  Generate the ASIS tree after writing the ALI file, since in ASIS
 846       --  mode, Write_ALI may in fact result in further tree decoration from
 847       --  the original tree file. Note that we dump the tree just before
 848       --  generating it, so that the dump will exactly reflect what is written
 849       --  out.
 850
 851       Treepr.Tree_Dump;
 852       Tree_Gen;
 853
 854       --  Finalize name table and we are all done
 855
 856       Namet.Finalize;
 857
 858    exception
 859       --  Handle fatal internal compiler errors
 860
 861       when Rtsfind.RE_Not_Available =>
 862          Comperr.Compiler_Abort ("RE_Not_Available");
 863
 864       when System.Assertions.Assert_Failure =>
 865          Comperr.Compiler_Abort ("Assert_Failure");
 866
 867       when Constraint_Error =>
 868          Comperr.Compiler_Abort ("Constraint_Error");
 869
 870       when Program_Error =>
 871          Comperr.Compiler_Abort ("Program_Error");
 872
 873       when Storage_Error =>
 874
 875          --  Assume this is a bug. If it is real, the message will in any case
 876          --  say Storage_Error, giving a strong hint!
 877
 878          Comperr.Compiler_Abort ("Storage_Error");
 879    end;
 880
 881    <<End_Of_Program>>
 882    null;
 883
 884    --  The outer exception handles an unrecoverable error
 885
 886 exception
 887    when Unrecoverable_Error =>
 888       Errout.Finalize (Last_Call => True);
 889       Errout.Output_Messages;
 890
 891       Set_Standard_Error;
 892       Write_Str ("compilation abandoned");
 893       Write_Eol;
 894
 895       Set_Standard_Output;
 896       Source_Dump;
 897       Tree_Dump;
 898       Exit_Program (E_Errors);
 899
 900 end Gnat1drv;