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