gcc/ada/par-load.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             P A R . L O A D                              --
   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
  27 --  The Par.Load procedure loads all units that are definitely required before
  28 --  it makes any sense at all to proceed with semantic analysis, including
  29 --  with'ed units, corresponding specs for bodies, parents of child specs,
  30 --  and parents of subunits. All these units are loaded and pointers installed
  31 --  in the tree as described in the spec of package Lib.
  32
  33 with Fname;    use Fname;
  34 with Fname.UF; use Fname.UF;
  35 with Lib.Load; use Lib.Load;
  36 with Uname;    use Uname;
  37 with Namet;    use Namet;
  38 with Casing;   use Casing;
  39 with Opt;      use Opt;
  40 with Osint;    use Osint;
  41 with Sinput.L; use Sinput.L;
  42 with Stylesw;  use Stylesw;
  43 with Validsw;  use Validsw;
  44
  45 with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
  46
  47 separate (Par)
  48 procedure Load is
  49
  50    File_Name : File_Name_Type;
  51    --  Name of file for current unit, derived from unit name
  52
  53    Cur_Unum : constant Unit_Number_Type := Current_Source_Unit;
  54    --  Unit number of unit that we just finished parsing. Note that we need
  55    --  to capture this, because Source_Unit will change as we parse new
  56    --  source files in the multiple main source file case.
  57
  58    Curunit : constant Node_Id := Cunit (Cur_Unum);
  59    --  Compilation unit node for current compilation unit
  60
  61    Loc : Source_Ptr := Sloc (Curunit);
  62    --  Source location for compilation unit node
  63
  64    Save_Style_Check  : Boolean;
  65    Save_Style_Checks : Style_Check_Options;
  66    --  Save style check so it can be restored later
  67
  68    Save_Validity_Check  : Boolean;
  69    Save_Validity_Checks : Validity_Check_Options;
  70    --  Save validity check so it can be restored later
  71
  72    With_Cunit : Node_Id;
  73    --  Compilation unit node for withed unit
  74
  75    Context_Node : Node_Id;
  76    --  Next node in context items list
  77
  78    With_Node : Node_Id;
  79    --  N_With_Clause node
  80
  81    Spec_Name : Unit_Name_Type;
  82    --  Unit name of required spec
  83
  84    Body_Name : Unit_Name_Type;
  85    --  Unit name of corresponding body
  86
  87    Unum : Unit_Number_Type;
  88    --  Unit number of loaded unit
  89
  90    function Same_File_Name_Except_For_Case
  91      (Expected_File_Name : File_Name_Type;
  92       Actual_File_Name   : File_Name_Type) return Boolean;
  93    --  Given an actual file name and an expected file name (the latter being
  94    --  derived from the unit name), determine if they are the same except for
  95    --  possibly different casing of letters.
  96
  97    ------------------------------------
  98    -- Same_File_Name_Except_For_Case --
  99    ------------------------------------
 100
 101    function Same_File_Name_Except_For_Case
 102      (Expected_File_Name : File_Name_Type;
 103       Actual_File_Name   : File_Name_Type) return Boolean
 104    is
 105    begin
 106       Get_Name_String (Actual_File_Name);
 107       Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
 108
 109       declare
 110          Lower_Case_Actual_File_Name : String (1 .. Name_Len);
 111
 112       begin
 113          Lower_Case_Actual_File_Name := Name_Buffer (1 .. Name_Len);
 114          Get_Name_String (Expected_File_Name);
 115          Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
 116          return Lower_Case_Actual_File_Name = Name_Buffer (1 .. Name_Len);
 117       end;
 118
 119    end Same_File_Name_Except_For_Case;
 120
 121 --  Start of processing for Load
 122
 123 begin
 124    --  Don't do any loads if we already had a fatal error
 125
 126    if Fatal_Error (Cur_Unum) then
 127       return;
 128    end if;
 129
 130    Save_Style_Check_Options (Save_Style_Checks);
 131    Save_Style_Check := Opt.Style_Check;
 132
 133    Save_Validity_Check_Options (Save_Validity_Checks);
 134    Save_Validity_Check := Opt.Validity_Checks_On;
 135
 136    --  If main unit, set Main_Unit_Entity (this will get overwritten if
 137    --  the main unit has a separate spec, that happens later on in Load)
 138
 139    if Cur_Unum = Main_Unit then
 140       Main_Unit_Entity := Cunit_Entity (Main_Unit);
 141    end if;
 142
 143    --  If we have no unit name, things are seriously messed up by previous
 144    --  errors, and we should not try to continue compilation.
 145
 146    if Unit_Name (Cur_Unum) = No_Name then
 147       raise Unrecoverable_Error;
 148    end if;
 149
 150    --  Next step, make sure that the unit name matches the file name
 151    --  and issue a warning message if not. We only output this for the
 152    --  main unit, since for other units it is more serious and is
 153    --  caught in a separate test below.
 154
 155    File_Name :=
 156      Get_File_Name
 157        (Unit_Name (Cur_Unum),
 158         Subunit => Nkind (Unit (Cunit (Cur_Unum))) = N_Subunit);
 159
 160    if Cur_Unum = Main_Unit
 161      and then File_Name /= Unit_File_Name (Cur_Unum)
 162      and then (File_Names_Case_Sensitive
 163                 or not Same_File_Name_Except_For_Case
 164                          (File_Name, Unit_File_Name (Cur_Unum)))
 165    then
 166       Error_Msg_Name_1 := File_Name;
 167       Error_Msg
 168         ("?file name does not match unit name, should be{", Sloc (Curunit));
 169    end if;
 170
 171    --  For units other than the main unit, the expected unit name is set and
 172    --  must be the same as the actual unit name, or we are in big trouble, and
 173    --  abandon the compilation since there are situations where this really
 174    --  gets us into bad trouble (e.g. some subunit situations).
 175
 176    if Cur_Unum /= Main_Unit
 177      and then Expected_Unit (Cur_Unum) /= Unit_Name (Cur_Unum)
 178    then
 179       Loc := Error_Location (Cur_Unum);
 180       Error_Msg_Name_1 := Unit_File_Name (Cur_Unum);
 181       Get_Name_String (Error_Msg_Name_1);
 182
 183       --  Check for predefined file case
 184
 185       if Name_Len > 1
 186         and then Name_Buffer (2) = '-'
 187         and then (Name_Buffer (1) = 'a'
 188                     or else
 189                   Name_Buffer (1) = 's'
 190                     or else
 191                   Name_Buffer (1) = 'i'
 192                     or else
 193                   Name_Buffer (1) = 'g')
 194       then
 195          declare
 196             Expect_Name : constant Name_Id := Expected_Unit (Cur_Unum);
 197             Actual_Name : constant Name_Id := Unit_Name (Cur_Unum);
 198
 199          begin
 200             Error_Msg_Name_1 := Expect_Name;
 201             Error_Msg ("% is not a predefined library unit!", Loc);
 202
 203             --  In the predefined file case, we know the user did not
 204             --  construct their own package, but we got the wrong one.
 205             --  This means that the name supplied by the user crunched
 206             --  to something we recognized, but then the file did not
 207             --  contain the unit expected. Most likely this is due to
 208             --  a misspelling, e.g.
 209
 210             --    with Ada.Calender;
 211
 212             --  This crunches to a-calend, which indeed contains the unit
 213             --  Ada.Calendar, and we can diagnose the misspelling. This
 214             --  is a simple heuristic, but it catches many common cases
 215             --  of misspelling of predefined unit names without needing
 216             --  a full list of them.
 217
 218             --  Before actually issinying the message, we will check that the
 219             --  unit name is indeed a plausible misspelling of the one we got.
 220
 221             if Is_Bad_Spelling_Of
 222               (Found  => Get_Name_String (Expect_Name),
 223                Expect => Get_Name_String (Actual_Name))
 224             then
 225                Error_Msg_Name_1 := Actual_Name;
 226                Error_Msg ("possible misspelling of %!", Loc);
 227             end if;
 228          end;
 229
 230       --  Non-predefined file name case. In this case we generate a message
 231       --  and then we quit, because we are in big trouble, and if we try
 232       --  to continue compilation, we get into some nasty situations
 233       --  (for example in some subunit cases).
 234
 235       else
 236          Error_Msg ("file { does not contain expected unit!", Loc);
 237          Error_Msg_Unit_1 := Expected_Unit (Cur_Unum);
 238          Error_Msg ("expected unit $!", Loc);
 239          Error_Msg_Unit_1 := Unit_Name (Cur_Unum);
 240          Error_Msg ("found unit $!", Loc);
 241       end if;
 242
 243       --  In both cases, remove the unit if it is the last unit (which it
 244       --  normally (always?) will be) so that it is out of the way later.
 245
 246       Remove_Unit (Cur_Unum);
 247    end if;
 248
 249    --  If current unit is a body, load its corresponding spec
 250
 251    if Nkind (Unit (Curunit)) = N_Package_Body
 252      or else Nkind (Unit (Curunit)) = N_Subprogram_Body
 253    then
 254       Spec_Name := Get_Spec_Name (Unit_Name (Cur_Unum));
 255       Unum :=
 256         Load_Unit
 257           (Load_Name  => Spec_Name,
 258            Required   => False,
 259            Subunit    => False,
 260            Error_Node => Curunit,
 261            Corr_Body  => Cur_Unum);
 262
 263       --  If we successfully load the unit, then set the spec pointer. Once
 264       --  again note that if the loaded unit has a fatal error, Load will
 265       --  have set our Fatal_Error flag to propagate this condition.
 266
 267       if Unum /= No_Unit then
 268          Set_Library_Unit (Curunit, Cunit (Unum));
 269
 270          --  If this is a separate spec for the main unit, then we reset
 271          --  Main_Unit_Entity to point to the entity for this separate spec
 272
 273          if Cur_Unum = Main_Unit then
 274             Main_Unit_Entity := Cunit_Entity (Unum);
 275          end if;
 276
 277       --  If we don't find the spec, then if we have a subprogram body, we
 278       --  are still OK, we just have a case of a body acting as its own spec
 279
 280       elsif Nkind (Unit (Curunit)) = N_Subprogram_Body then
 281          Set_Acts_As_Spec (Curunit, True);
 282          Set_Library_Unit (Curunit, Curunit);
 283
 284       --  Otherwise we do have an error, repeat the load request for the spec
 285       --  with Required set True to generate an appropriate error message.
 286
 287       else
 288          Unum :=
 289            Load_Unit
 290              (Load_Name  => Spec_Name,
 291               Required   => True,
 292               Subunit    => False,
 293               Error_Node => Curunit);
 294          return;
 295       end if;
 296
 297    --  If current unit is a child unit spec, load its parent
 298
 299    elsif Nkind (Unit (Curunit)) = N_Package_Declaration
 300      or else Nkind (Unit (Curunit)) =  N_Subprogram_Declaration
 301      or else Nkind (Unit (Curunit)) in N_Generic_Declaration
 302      or else Nkind (Unit (Curunit)) in N_Generic_Instantiation
 303      or else Nkind (Unit (Curunit)) in N_Renaming_Declaration
 304    then
 305       --  Turn style and validity checks off for parent unit
 306
 307       if not GNAT_Mode then
 308          Reset_Style_Check_Options;
 309          Reset_Validity_Check_Options;
 310       end if;
 311
 312       Spec_Name := Get_Parent_Spec_Name (Unit_Name (Cur_Unum));
 313
 314       if Spec_Name /= No_Name then
 315          Unum :=
 316            Load_Unit
 317              (Load_Name  => Spec_Name,
 318               Required   => True,
 319               Subunit    => False,
 320               Error_Node => Curunit);
 321
 322          if Unum /= No_Unit then
 323             Set_Parent_Spec (Unit (Curunit), Cunit (Unum));
 324          end if;
 325       end if;
 326
 327    --  If current unit is a subunit, then load its parent body
 328
 329    elsif Nkind (Unit (Curunit)) = N_Subunit then
 330       Body_Name := Get_Parent_Body_Name (Unit_Name (Cur_Unum));
 331       Unum :=
 332         Load_Unit
 333           (Load_Name  => Body_Name,
 334            Required   => True,
 335            Subunit    => True,
 336            Error_Node => Name (Unit (Curunit)));
 337
 338       if Unum /= No_Unit then
 339          Set_Library_Unit (Curunit, Cunit (Unum));
 340       end if;
 341
 342    end if;
 343
 344    --  Now we load with'ed units, with style/validity checks turned off
 345
 346    if not GNAT_Mode then
 347       Reset_Style_Check_Options;
 348       Reset_Validity_Check_Options;
 349    end if;
 350
 351    --  Loop through context items
 352
 353    Context_Node := First (Context_Items (Curunit));
 354    while Present (Context_Node) loop
 355
 356       if Nkind (Context_Node) = N_With_Clause then
 357          With_Node := Context_Node;
 358          Spec_Name := Get_Unit_Name (With_Node);
 359
 360          Unum :=
 361            Load_Unit
 362              (Load_Name  => Spec_Name,
 363               Required   => False,
 364               Subunit    => False,
 365               Error_Node => With_Node,
 366               Renamings  => True);
 367
 368          --  If we find the unit, then set spec pointer in the N_With_Clause
 369          --  to point to the compilation unit for the spec. Remember that
 370          --  the Load routine itself sets our Fatal_Error flag if the loaded
 371          --  unit gets a fatal error, so we don't need to worry about that.
 372
 373          if Unum /= No_Unit then
 374             Set_Library_Unit (With_Node, Cunit (Unum));
 375
 376          --  If the spec isn't found, then try finding the corresponding
 377          --  body, since it is possible that we have a subprogram body
 378          --  that is acting as a spec (since no spec is present).
 379
 380          else
 381             Body_Name := Get_Body_Name (Spec_Name);
 382             Unum :=
 383               Load_Unit
 384                 (Load_Name  => Body_Name,
 385                  Required   => False,
 386                  Subunit    => False,
 387                  Error_Node => With_Node,
 388                  Renamings  => True);
 389
 390             --  If we got a subprogram body, then mark that we are using
 391             --  the body as a spec in the file table, and set the spec
 392             --  pointer in the N_With_Clause to point to the body entity.
 393
 394             if Unum /= No_Unit
 395               and then Nkind (Unit (Cunit (Unum))) = N_Subprogram_Body
 396             then
 397                With_Cunit := Cunit (Unum);
 398                Set_Library_Unit (With_Node, With_Cunit);
 399                Set_Acts_As_Spec (With_Cunit, True);
 400                Set_Library_Unit (With_Cunit, With_Cunit);
 401
 402             --  If we couldn't find the body, or if it wasn't a body spec
 403             --  then we are in trouble. We make one more call to Load to
 404             --  require the spec. We know it will fail of course, the
 405             --  purpose is to generate the required error message (we prefer
 406             --  that this message refer to the missing spec, not the body)
 407
 408             else
 409                Unum :=
 410                  Load_Unit
 411                    (Load_Name  => Spec_Name,
 412                     Required   => True,
 413                     Subunit    => False,
 414                     Error_Node => With_Node,
 415                     Renamings  => True);
 416
 417                --  Here we create a dummy package unit for the missing unit
 418
 419                Unum := Create_Dummy_Package_Unit (With_Node, Spec_Name);
 420                Set_Library_Unit (With_Node, Cunit (Unum));
 421             end if;
 422          end if;
 423       end if;
 424
 425       Next (Context_Node);
 426    end loop;
 427
 428    --  Restore style/validity check mode for main unit
 429
 430    Set_Style_Check_Options (Save_Style_Checks);
 431    Opt.Style_Check := Save_Style_Check;
 432    Set_Validity_Check_Options (Save_Validity_Checks);
 433    Opt.Validity_Checks_On := Save_Validity_Check;
 434 end Load;