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-2020, 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 32with Fname.UF; use Fname.UF; 33with Lib.Load; use Lib.Load; 34with Namet.Sp; use Namet.Sp; 35with Uname; use Uname; 36with Osint; use Osint; 37with Sinput.L; use Sinput.L; 38with Stylesw; use Stylesw; 39 40with GNAT.Spelling_Checker; use GNAT.Spelling_Checker; 41 42separate (Par) 43procedure 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 122begin 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 133 -- the 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 (2) = '-' 186 and then (Name_Buffer (1) = 'a' 187 or else 188 Name_Buffer (1) = 's' 189 or else 190 Name_Buffer (1) = 'i' 191 or else 192 Name_Buffer (1) = 'g') 193 then 194 declare 195 Expect_Name : constant Unit_Name_Type := Expected_Unit (Cur_Unum); 196 Actual_Name : constant Unit_Name_Type := Unit_Name (Cur_Unum); 197 198 begin 199 Error_Msg_Unit_1 := Expect_Name; 200 Error_Msg -- CODEFIX 201 ("$$ 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 issuing 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 (Name_Id (Expect_Name), Name_Id (Actual_Name)) 223 then 224 Error_Msg_Unit_1 := Actual_Name; 225 Error_Msg -- CODEFIX 226 ("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 PMES => (Cur_Unum = Main_Unit)); 263 264 -- If we successfully load the unit, then set the spec/body pointers. 265 -- Once again note that if the loaded unit has a fatal error, Load will 266 -- have set our Fatal_Error flag to propagate this condition. 267 268 if Unum /= No_Unit then 269 Set_Library_Unit (Curunit, Cunit (Unum)); 270 Set_Library_Unit (Cunit (Unum), Curunit); 271 272 -- If this is a separate spec for the main unit, then we reset 273 -- Main_Unit_Entity to point to the entity for this separate spec 274 -- and this is also where we generate the SCO's for this spec. 275 276 if Cur_Unum = Main_Unit then 277 Main_Unit_Entity := Cunit_Entity (Unum); 278 279 if Generate_SCO then 280 SCO_Record_Raw (Unum); 281 end if; 282 end if; 283 284 -- If we don't find the spec, then if we have a subprogram body, we 285 -- are still OK, we just have a case of a body acting as its own spec 286 287 elsif Nkind (Unit (Curunit)) = N_Subprogram_Body then 288 Set_Acts_As_Spec (Curunit, True); 289 Set_Library_Unit (Curunit, Curunit); 290 291 -- Otherwise we do have an error, repeat the load request for the spec 292 -- with Required set True to generate an appropriate error message. 293 294 else 295 Unum := 296 Load_Unit 297 (Load_Name => Spec_Name, 298 Required => True, 299 Subunit => False, 300 Error_Node => Curunit); 301 return; 302 end if; 303 304 -- If current unit is a child unit spec, load its parent. If the child unit 305 -- is loaded through a limited with, the parent must be as well. 306 307 elsif Nkind (Unit (Curunit)) = N_Package_Declaration 308 or else Nkind (Unit (Curunit)) = N_Subprogram_Declaration 309 or else Nkind (Unit (Curunit)) in N_Generic_Declaration 310 or else Nkind (Unit (Curunit)) in N_Generic_Instantiation 311 or else Nkind (Unit (Curunit)) in N_Renaming_Declaration 312 then 313 -- Turn style checks off for parent unit 314 315 if not GNAT_Mode then 316 Reset_Style_Check_Options; 317 end if; 318 319 Spec_Name := Get_Parent_Spec_Name (Unit_Name (Cur_Unum)); 320 321 if Present (Spec_Name) then 322 Unum := 323 Load_Unit 324 (Load_Name => Spec_Name, 325 Required => True, 326 Subunit => False, 327 Error_Node => Curunit); 328 329 if Unum /= No_Unit then 330 Set_Parent_Spec (Unit (Curunit), Cunit (Unum)); 331 end if; 332 end if; 333 334 -- If current unit is a subunit, then load its parent body 335 336 elsif Nkind (Unit (Curunit)) = N_Subunit then 337 Body_Name := Get_Parent_Body_Name (Unit_Name (Cur_Unum)); 338 Unum := 339 Load_Unit 340 (Load_Name => Body_Name, 341 Required => True, 342 Subunit => False, 343 Error_Node => Name (Unit (Curunit))); 344 345 if Unum /= No_Unit then 346 Set_Library_Unit (Curunit, Cunit (Unum)); 347 end if; 348 end if; 349 350 -- Now we load with'ed units, with style checks turned off 351 352 if not GNAT_Mode then 353 Reset_Style_Check_Options; 354 end if; 355 356 -- Load the context items in two rounds: the first round handles normal 357 -- withed units and the second round handles Ada 2005 limited-withed units. 358 -- This is required to allow the low-level circuitry that detects circular 359 -- dependencies of units the correct notification of the following error: 360 361 -- limited with D; 362 -- with D; with C; 363 -- package C is ... package D is ... 364 365 for Round in 1 .. 2 loop 366 Context_Node := First (Context_Items (Curunit)); 367 while Present (Context_Node) loop 368 369 -- During the first round we check if there is some limited-with 370 -- context clause; otherwise the second round will be skipped 371 372 if Nkind (Context_Node) = N_With_Clause 373 and then Round = 1 374 and then Limited_Present (Context_Node) 375 then 376 Limited_With_Found := True; 377 end if; 378 379 if Nkind (Context_Node) = N_With_Clause 380 and then ((Round = 1 and then not Limited_Present (Context_Node)) 381 or else 382 (Round = 2 and then Limited_Present (Context_Node))) 383 then 384 With_Node := Context_Node; 385 Spec_Name := Get_Unit_Name (With_Node); 386 387 Unum := 388 Load_Unit 389 (Load_Name => Spec_Name, 390 Required => False, 391 Subunit => False, 392 Error_Node => With_Node, 393 Renamings => True, 394 With_Node => Context_Node); 395 396 -- If we find the unit, then set spec pointer in the N_With_Clause 397 -- to point to the compilation unit for the spec. Remember that 398 -- the Load routine itself sets our Fatal_Error flag if the loaded 399 -- unit gets a fatal error, so we don't need to worry about that. 400 401 if Unum /= No_Unit then 402 Set_Library_Unit (With_Node, Cunit (Unum)); 403 404 -- If the spec isn't found, then try finding the corresponding 405 -- body, since it is possible that we have a subprogram body 406 -- that is acting as a spec (since no spec is present). 407 408 else 409 Body_Name := Get_Body_Name (Spec_Name); 410 Unum := 411 Load_Unit 412 (Load_Name => Body_Name, 413 Required => False, 414 Subunit => False, 415 Error_Node => With_Node, 416 Renamings => True); 417 418 -- If we got a subprogram body, then mark that we are using 419 -- the body as a spec in the file table, and set the spec 420 -- pointer in the N_With_Clause to point to the body entity. 421 422 if Unum /= No_Unit 423 and then Nkind (Unit (Cunit (Unum))) = N_Subprogram_Body 424 then 425 With_Cunit := Cunit (Unum); 426 Set_Library_Unit (With_Node, With_Cunit); 427 Set_Acts_As_Spec (With_Cunit, True); 428 Set_Library_Unit (With_Cunit, With_Cunit); 429 430 -- If we couldn't find the body, or if it wasn't a body spec 431 -- then we are in trouble. We make one more call to Load to 432 -- require the spec. We know it will fail of course, the 433 -- purpose is to generate the required error message (we prefer 434 -- that this message refer to the missing spec, not the body) 435 436 else 437 Unum := 438 Load_Unit 439 (Load_Name => Spec_Name, 440 Required => True, 441 Subunit => False, 442 Error_Node => With_Node, 443 Renamings => True); 444 445 -- Here we create a dummy package unit for the missing unit 446 447 Unum := Create_Dummy_Package_Unit (With_Node, Spec_Name); 448 Set_Library_Unit (With_Node, Cunit (Unum)); 449 end if; 450 end if; 451 end if; 452 453 Next (Context_Node); 454 end loop; 455 456 exit when not Limited_With_Found; 457 end loop; 458 459 -- Restore style/validity check mode for main unit 460 461 Set_Style_Check_Options (Save_Style_Checks); 462 Opt.Style_Check := Save_Style_Check; 463end Load; 464