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