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