1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- P R J . P A R T -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2001-2012, 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 26with Atree; use Atree; 27with Err_Vars; use Err_Vars; 28with Opt; use Opt; 29with Osint; use Osint; 30with Output; use Output; 31with Prj.Com; use Prj.Com; 32with Prj.Dect; 33with Prj.Env; use Prj.Env; 34with Prj.Err; use Prj.Err; 35with Sinput; use Sinput; 36with Sinput.P; use Sinput.P; 37with Snames; 38with Table; 39 40with Ada.Characters.Handling; use Ada.Characters.Handling; 41with Ada.Exceptions; use Ada.Exceptions; 42 43with GNAT.HTable; use GNAT.HTable; 44 45package body Prj.Part is 46 47 Buffer : String_Access; 48 Buffer_Last : Natural := 0; 49 50 Dir_Sep : Character renames GNAT.OS_Lib.Directory_Separator; 51 52 ------------------------------------ 53 -- Local Packages and Subprograms -- 54 ------------------------------------ 55 56 type With_Id is new Nat; 57 No_With : constant With_Id := 0; 58 59 type With_Record is record 60 Path : Path_Name_Type; 61 Location : Source_Ptr; 62 Limited_With : Boolean; 63 Node : Project_Node_Id; 64 Next : With_Id; 65 end record; 66 -- Information about an imported project, to be put in table Withs below 67 68 package Withs is new Table.Table 69 (Table_Component_Type => With_Record, 70 Table_Index_Type => With_Id, 71 Table_Low_Bound => 1, 72 Table_Initial => 10, 73 Table_Increment => 100, 74 Table_Name => "Prj.Part.Withs"); 75 -- Table used to store temporarily paths and locations of imported 76 -- projects. These imported projects will be effectively parsed later: just 77 -- before parsing the current project for the non limited withed projects, 78 -- after getting its name; after complete parsing of the current project 79 -- for the limited withed projects. 80 81 type Names_And_Id is record 82 Path_Name : Path_Name_Type; 83 Canonical_Path_Name : Path_Name_Type; 84 Id : Project_Node_Id; 85 Limited_With : Boolean; 86 end record; 87 88 package Project_Stack is new Table.Table 89 (Table_Component_Type => Names_And_Id, 90 Table_Index_Type => Nat, 91 Table_Low_Bound => 1, 92 Table_Initial => 10, 93 Table_Increment => 100, 94 Table_Name => "Prj.Part.Project_Stack"); 95 -- This table is used to detect circular dependencies 96 -- for imported and extended projects and to get the project ids of 97 -- limited imported projects when there is a circularity with at least 98 -- one limited imported project file. 99 100 package Virtual_Hash is new GNAT.HTable.Simple_HTable 101 (Header_Num => Header_Num, 102 Element => Project_Node_Id, 103 No_Element => Project_Node_High_Bound, 104 Key => Project_Node_Id, 105 Hash => Prj.Tree.Hash, 106 Equal => "="); 107 -- Hash table to store the node ids of projects for which a virtual 108 -- extending project need to be created. The corresponding value is the 109 -- head of a list of WITH clauses corresponding to the context of the 110 -- enclosing EXTEND ALL projects. Note: Default_Element is Project_Node_ 111 -- High_Bound because we want Empty_Node to be a possible value. 112 113 package Processed_Hash is new GNAT.HTable.Simple_HTable 114 (Header_Num => Header_Num, 115 Element => Boolean, 116 No_Element => False, 117 Key => Project_Node_Id, 118 Hash => Prj.Tree.Hash, 119 Equal => "="); 120 -- Hash table to store the project process when looking for project that 121 -- need to have a virtual extending project, to avoid processing the same 122 -- project twice. 123 124 function Has_Circular_Dependencies 125 (Flags : Processing_Flags; 126 Normed_Path_Name : Path_Name_Type; 127 Canonical_Path_Name : Path_Name_Type) return Boolean; 128 -- Check for a circular dependency in the loaded project. 129 -- Generates an error message in such a case. 130 131 procedure Read_Project_Qualifier 132 (Flags : Processing_Flags; 133 In_Tree : Project_Node_Tree_Ref; 134 Is_Config_File : Boolean; 135 Qualifier_Location : out Source_Ptr; 136 Project : Project_Node_Id); 137 -- Check if there is a qualifier before the reserved word "project" 138 139 -- Hash table to cache project path to avoid looking for them on the path 140 141 procedure Check_Extending_All_Imports 142 (Flags : Processing_Flags; 143 In_Tree : Project_Node_Tree_Ref; 144 Project : Project_Node_Id); 145 -- Check that a non extending-all project does not import an 146 -- extending-all project. 147 148 procedure Check_Aggregate_Imports 149 (Flags : Processing_Flags; 150 In_Tree : Project_Node_Tree_Ref; 151 Project : Project_Node_Id); 152 -- Check that an aggregate project only imports abstract projects 153 154 procedure Create_Virtual_Extending_Project 155 (For_Project : Project_Node_Id; 156 Main_Project : Project_Node_Id; 157 Extension_Withs : Project_Node_Id; 158 In_Tree : Project_Node_Tree_Ref); 159 -- Create a virtual extending project of For_Project. Main_Project is 160 -- the extending all project. Extension_Withs is the head of a WITH clause 161 -- list to be added to the created virtual project. 162 -- 163 -- The String_Value_Of is not set for the automatically added with 164 -- clause and keeps the default value of No_Name. This enables Prj.PP 165 -- to skip these automatically added with clauses to be processed. 166 167 procedure Look_For_Virtual_Projects_For 168 (Proj : Project_Node_Id; 169 In_Tree : Project_Node_Tree_Ref; 170 Potentially_Virtual : Boolean); 171 -- Look for projects that need to have a virtual extending project. 172 -- This procedure is recursive. If called with Potentially_Virtual set to 173 -- True, then Proj may need an virtual extending project; otherwise it 174 -- does not (because it is already extended), but other projects that it 175 -- imports may need to be virtually extended. 176 177 type Extension_Origin is (None, Extending_Simple, Extending_All); 178 -- Type of parameter From_Extended for procedures Parse_Single_Project and 179 -- Post_Parse_Context_Clause. Extending_All means that we are parsing the 180 -- tree rooted at an extending all project. 181 182 procedure Parse_Single_Project 183 (In_Tree : Project_Node_Tree_Ref; 184 Project : out Project_Node_Id; 185 Extends_All : out Boolean; 186 Path_Name_Id : Path_Name_Type; 187 Extended : Boolean; 188 From_Extended : Extension_Origin; 189 In_Limited : Boolean; 190 Packages_To_Check : String_List_Access; 191 Depth : Natural; 192 Current_Dir : String; 193 Is_Config_File : Boolean; 194 Env : in out Environment); 195 -- Parse a project file. This is a recursive procedure: it calls itself for 196 -- imported and extended projects. When From_Extended is not None, if the 197 -- project has already been parsed and is an extended project A, return the 198 -- ultimate (not extended) project that extends A. When In_Limited is True, 199 -- the importing path includes at least one "limited with". When parsing 200 -- configuration projects, do not allow a depth > 1. 201 -- 202 -- Is_Config_File should be set to True if the project represents a config 203 -- file (.cgpr) since some specific checks apply. 204 205 procedure Pre_Parse_Context_Clause 206 (In_Tree : Project_Node_Tree_Ref; 207 Context_Clause : out With_Id; 208 Is_Config_File : Boolean; 209 Flags : Processing_Flags); 210 -- Parse the context clause of a project. Store the paths and locations of 211 -- the imported projects in table Withs. Does nothing if there is no 212 -- context clause (if the current token is not "with" or "limited" followed 213 -- by "with"). 214 -- Is_Config_File should be set to True if the project represents a config 215 -- file (.cgpr) since some specific checks apply. 216 217 procedure Post_Parse_Context_Clause 218 (Context_Clause : With_Id; 219 In_Tree : Project_Node_Tree_Ref; 220 In_Limited : Boolean; 221 Limited_Withs : Boolean; 222 Imported_Projects : in out Project_Node_Id; 223 Project_Directory : Path_Name_Type; 224 From_Extended : Extension_Origin; 225 Packages_To_Check : String_List_Access; 226 Depth : Natural; 227 Current_Dir : String; 228 Is_Config_File : Boolean; 229 Env : in out Environment); 230 -- Parse the imported projects that have been stored in table Withs, if 231 -- any. From_Extended is used for the call to Parse_Single_Project below. 232 -- 233 -- When In_Limited is True, the importing path includes at least one 234 -- "limited with". When Limited_Withs is False, only non limited withed 235 -- projects are parsed. When Limited_Withs is True, only limited withed 236 -- projects are parsed. 237 -- 238 -- Is_Config_File should be set to True if the project represents a config 239 -- file (.cgpr) since some specific checks apply. 240 241 function Project_Name_From 242 (Path_Name : String; 243 Is_Config_File : Boolean) return Name_Id; 244 -- Returns the name of the project that corresponds to its path name. 245 -- Returns No_Name if the path name is invalid, because the corresponding 246 -- project name does not have the syntax of an ada identifier. 247 248 function Copy_With_Clause 249 (With_Clause : Project_Node_Id; 250 In_Tree : Project_Node_Tree_Ref; 251 Next_Clause : Project_Node_Id) return Project_Node_Id; 252 -- Return a copy of With_Clause in In_Tree, whose Next_With_Clause is the 253 -- indicated one. 254 255 ---------------------- 256 -- Copy_With_Clause -- 257 ---------------------- 258 259 function Copy_With_Clause 260 (With_Clause : Project_Node_Id; 261 In_Tree : Project_Node_Tree_Ref; 262 Next_Clause : Project_Node_Id) return Project_Node_Id 263 is 264 New_With_Clause : constant Project_Node_Id := 265 Default_Project_Node (In_Tree, N_With_Clause); 266 begin 267 Set_Name_Of (New_With_Clause, In_Tree, 268 Name_Of (With_Clause, In_Tree)); 269 Set_Path_Name_Of (New_With_Clause, In_Tree, 270 Path_Name_Of (With_Clause, In_Tree)); 271 Set_Project_Node_Of (New_With_Clause, In_Tree, 272 Project_Node_Of (With_Clause, In_Tree)); 273 Set_Next_With_Clause_Of (New_With_Clause, In_Tree, Next_Clause); 274 275 return New_With_Clause; 276 end Copy_With_Clause; 277 278 -------------------------------------- 279 -- Create_Virtual_Extending_Project -- 280 -------------------------------------- 281 282 procedure Create_Virtual_Extending_Project 283 (For_Project : Project_Node_Id; 284 Main_Project : Project_Node_Id; 285 Extension_Withs : Project_Node_Id; 286 In_Tree : Project_Node_Tree_Ref) 287 is 288 289 Virtual_Name : constant String := 290 Virtual_Prefix & 291 Get_Name_String (Name_Of (For_Project, In_Tree)); 292 -- The name of the virtual extending project 293 294 Virtual_Name_Id : Name_Id; 295 -- Virtual extending project name id 296 297 Virtual_Path_Id : Path_Name_Type; 298 -- Fake path name of the virtual extending project. The directory is 299 -- the same directory as the extending all project. 300 301 -- The source of the virtual extending project is something like: 302 303 -- project V$<project name> extends <project path> is 304 305 -- for Source_Dirs use (); 306 307 -- end V$<project name>; 308 309 -- The project directory cannot be specified during parsing; it will be 310 -- put directly in the virtual extending project data during processing. 311 312 -- Nodes that made up the virtual extending project 313 314 Virtual_Project : Project_Node_Id; 315 With_Clause : constant Project_Node_Id := 316 Default_Project_Node 317 (In_Tree, N_With_Clause); 318 Project_Declaration : Project_Node_Id; 319 Source_Dirs_Declaration : constant Project_Node_Id := 320 Default_Project_Node 321 (In_Tree, N_Declarative_Item); 322 Source_Dirs_Attribute : constant Project_Node_Id := 323 Default_Project_Node 324 (In_Tree, N_Attribute_Declaration, List); 325 Source_Dirs_Expression : constant Project_Node_Id := 326 Default_Project_Node 327 (In_Tree, N_Expression, List); 328 Source_Dirs_Term : constant Project_Node_Id := 329 Default_Project_Node 330 (In_Tree, N_Term, List); 331 Source_Dirs_List : constant Project_Node_Id := 332 Default_Project_Node 333 (In_Tree, N_Literal_String_List, List); 334 335 begin 336 -- Get the virtual path name 337 338 Get_Name_String (Path_Name_Of (Main_Project, In_Tree)); 339 340 while Name_Len > 0 341 and then Name_Buffer (Name_Len) /= Directory_Separator 342 and then Name_Buffer (Name_Len) /= '/' 343 loop 344 Name_Len := Name_Len - 1; 345 end loop; 346 347 Name_Buffer (Name_Len + 1 .. Name_Len + Virtual_Name'Length) := 348 Virtual_Name; 349 Name_Len := Name_Len + Virtual_Name'Length; 350 Virtual_Path_Id := Name_Find; 351 352 -- Get the virtual name id 353 354 Name_Len := Virtual_Name'Length; 355 Name_Buffer (1 .. Name_Len) := Virtual_Name; 356 Virtual_Name_Id := Name_Find; 357 358 Virtual_Project := Create_Project 359 (In_Tree => In_Tree, 360 Name => Virtual_Name_Id, 361 Full_Path => Virtual_Path_Id, 362 Is_Config_File => False); 363 364 Project_Declaration := Project_Declaration_Of (Virtual_Project, In_Tree); 365 366 -- Add a WITH clause to the main project to import the newly created 367 -- virtual extending project. 368 369 Set_Name_Of (With_Clause, In_Tree, Virtual_Name_Id); 370 Set_Path_Name_Of (With_Clause, In_Tree, Virtual_Path_Id); 371 Set_Project_Node_Of (With_Clause, In_Tree, Virtual_Project); 372 Set_Next_With_Clause_Of 373 (With_Clause, In_Tree, First_With_Clause_Of (Main_Project, In_Tree)); 374 Set_First_With_Clause_Of (Main_Project, In_Tree, With_Clause); 375 376 -- Copy with clauses for projects imported by the extending-all project 377 378 declare 379 Org_With_Clause : Project_Node_Id := Extension_Withs; 380 New_With_Clause : Project_Node_Id := Empty_Node; 381 382 begin 383 while Present (Org_With_Clause) loop 384 New_With_Clause := 385 Copy_With_Clause (Org_With_Clause, In_Tree, New_With_Clause); 386 387 Org_With_Clause := Next_With_Clause_Of (Org_With_Clause, In_Tree); 388 end loop; 389 390 Set_First_With_Clause_Of (Virtual_Project, In_Tree, New_With_Clause); 391 end; 392 393 -- Virtual project node 394 395 Set_Location_Of 396 (Virtual_Project, In_Tree, Location_Of (Main_Project, In_Tree)); 397 Set_Extended_Project_Path_Of 398 (Virtual_Project, In_Tree, Path_Name_Of (For_Project, In_Tree)); 399 400 -- Project declaration 401 402 Set_First_Declarative_Item_Of 403 (Project_Declaration, In_Tree, Source_Dirs_Declaration); 404 Set_Extended_Project_Of (Project_Declaration, In_Tree, For_Project); 405 406 -- Source_Dirs declaration 407 408 Set_Current_Item_Node 409 (Source_Dirs_Declaration, In_Tree, Source_Dirs_Attribute); 410 411 -- Source_Dirs attribute 412 413 Set_Name_Of (Source_Dirs_Attribute, In_Tree, Snames.Name_Source_Dirs); 414 Set_Expression_Of 415 (Source_Dirs_Attribute, In_Tree, Source_Dirs_Expression); 416 417 -- Source_Dirs expression 418 419 Set_First_Term (Source_Dirs_Expression, In_Tree, Source_Dirs_Term); 420 421 -- Source_Dirs term 422 423 Set_Current_Term (Source_Dirs_Term, In_Tree, Source_Dirs_List); 424 425 -- Source_Dirs empty list: nothing to do 426 end Create_Virtual_Extending_Project; 427 428 ----------------------------------- 429 -- Look_For_Virtual_Projects_For -- 430 ----------------------------------- 431 432 Extension_Withs : Project_Node_Id; 433 -- Head of the current EXTENDS ALL imports list. When creating virtual 434 -- projects for an EXTENDS ALL, we import in each virtual project all 435 -- of the projects that appear in WITH clauses of the extending projects. 436 -- This ensures that virtual projects share a consistent environment (in 437 -- particular if a project imported by one of the extending projects 438 -- replaces some runtime units). 439 440 procedure Look_For_Virtual_Projects_For 441 (Proj : Project_Node_Id; 442 In_Tree : Project_Node_Tree_Ref; 443 Potentially_Virtual : Boolean) 444 is 445 Declaration : Project_Node_Id := Empty_Node; 446 -- Node for the project declaration of Proj 447 448 With_Clause : Project_Node_Id := Empty_Node; 449 -- Node for a with clause of Proj 450 451 Imported : Project_Node_Id := Empty_Node; 452 -- Node for a project imported by Proj 453 454 Extended : Project_Node_Id := Empty_Node; 455 -- Node for the eventual project extended by Proj 456 457 Extends_All : Boolean := False; 458 -- Set True if Proj is an EXTENDS ALL project 459 460 Saved_Extension_Withs : constant Project_Node_Id := Extension_Withs; 461 462 begin 463 -- Nothing to do if Proj is undefined or has already been processed 464 465 if Present (Proj) and then not Processed_Hash.Get (Proj) then 466 467 -- Make sure the project will not be processed again 468 469 Processed_Hash.Set (Proj, True); 470 471 Declaration := Project_Declaration_Of (Proj, In_Tree); 472 473 if Present (Declaration) then 474 Extended := Extended_Project_Of (Declaration, In_Tree); 475 Extends_All := Is_Extending_All (Proj, In_Tree); 476 end if; 477 478 -- If this is a project that may need a virtual extending project 479 -- and it is not itself an extending project, put it in the list. 480 481 if Potentially_Virtual and then No (Extended) then 482 Virtual_Hash.Set (Proj, Extension_Withs); 483 end if; 484 485 -- Now check the projects it imports 486 487 With_Clause := First_With_Clause_Of (Proj, In_Tree); 488 while Present (With_Clause) loop 489 Imported := Project_Node_Of (With_Clause, In_Tree); 490 491 if Present (Imported) then 492 Look_For_Virtual_Projects_For 493 (Imported, In_Tree, Potentially_Virtual => True); 494 end if; 495 496 if Extends_All then 497 498 -- This is an EXTENDS ALL project: prepend each of its WITH 499 -- clauses to the currently active list of extension deps. 500 501 Extension_Withs := 502 Copy_With_Clause (With_Clause, In_Tree, Extension_Withs); 503 end if; 504 505 With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); 506 end loop; 507 508 -- Check also the eventual project extended by Proj. As this project 509 -- is already extended, call recursively with Potentially_Virtual 510 -- being False. 511 512 Look_For_Virtual_Projects_For 513 (Extended, In_Tree, Potentially_Virtual => False); 514 515 Extension_Withs := Saved_Extension_Withs; 516 end if; 517 end Look_For_Virtual_Projects_For; 518 519 ----------- 520 -- Parse -- 521 ----------- 522 523 procedure Parse 524 (In_Tree : Project_Node_Tree_Ref; 525 Project : out Project_Node_Id; 526 Project_File_Name : String; 527 Errout_Handling : Errout_Mode := Always_Finalize; 528 Packages_To_Check : String_List_Access; 529 Store_Comments : Boolean := False; 530 Current_Directory : String := ""; 531 Is_Config_File : Boolean; 532 Env : in out Prj.Tree.Environment; 533 Target_Name : String := "") 534 is 535 Dummy : Boolean; 536 pragma Warnings (Off, Dummy); 537 538 Real_Project_File_Name : String_Access := 539 Osint.To_Canonical_File_Spec 540 (Project_File_Name); 541 Path_Name_Id : Path_Name_Type; 542 543 begin 544 In_Tree.Incomplete_With := False; 545 546 if not Is_Initialized (Env.Project_Path) then 547 Prj.Env.Initialize_Default_Project_Path 548 (Env.Project_Path, Target_Name); 549 end if; 550 551 if Real_Project_File_Name = null then 552 Real_Project_File_Name := new String'(Project_File_Name); 553 end if; 554 555 Project := Empty_Node; 556 557 Find_Project (Env.Project_Path, 558 Project_File_Name => Real_Project_File_Name.all, 559 Directory => Current_Directory, 560 Path => Path_Name_Id); 561 Free (Real_Project_File_Name); 562 563 if Errout_Handling /= Never_Finalize then 564 Prj.Err.Initialize; 565 end if; 566 567 Prj.Err.Scanner.Set_Comment_As_Token (Store_Comments); 568 Prj.Err.Scanner.Set_End_Of_Line_As_Token (Store_Comments); 569 570 if Path_Name_Id = No_Path then 571 declare 572 P : String_Access; 573 begin 574 Get_Path (Env.Project_Path, Path => P); 575 576 Prj.Com.Fail 577 ("project file """ 578 & Project_File_Name 579 & """ not found in " 580 & P.all); 581 Project := Empty_Node; 582 return; 583 end; 584 end if; 585 586 -- Parse the main project file 587 588 begin 589 Parse_Single_Project 590 (In_Tree => In_Tree, 591 Project => Project, 592 Extends_All => Dummy, 593 Path_Name_Id => Path_Name_Id, 594 Extended => False, 595 From_Extended => None, 596 In_Limited => False, 597 Packages_To_Check => Packages_To_Check, 598 Depth => 0, 599 Current_Dir => Current_Directory, 600 Is_Config_File => Is_Config_File, 601 Env => Env); 602 603 exception 604 when Types.Unrecoverable_Error => 605 606 -- Unrecoverable_Error is raised when a line is too long. 607 -- A meaningful error message will be displayed later. 608 609 Project := Empty_Node; 610 end; 611 612 -- If Project is an extending-all project, create the eventual 613 -- virtual extending projects and check that there are no illegally 614 -- imported projects. 615 616 if Present (Project) 617 and then Is_Extending_All (Project, In_Tree) 618 then 619 -- First look for projects that potentially need a virtual 620 -- extending project. 621 622 Virtual_Hash.Reset; 623 Processed_Hash.Reset; 624 625 -- Mark the extending all project as processed, to avoid checking 626 -- the imported projects in case of a "limited with" on this 627 -- extending all project. 628 629 Processed_Hash.Set (Project, True); 630 631 declare 632 Declaration : constant Project_Node_Id := 633 Project_Declaration_Of (Project, In_Tree); 634 begin 635 Extension_Withs := First_With_Clause_Of (Project, In_Tree); 636 Look_For_Virtual_Projects_For 637 (Extended_Project_Of (Declaration, In_Tree), In_Tree, 638 Potentially_Virtual => False); 639 end; 640 641 -- Now, check the projects directly imported by the main project. 642 -- Remove from the potentially virtual any project extended by one 643 -- of these imported projects. 644 645 declare 646 With_Clause : Project_Node_Id; 647 Imported : Project_Node_Id := Empty_Node; 648 Declaration : Project_Node_Id := Empty_Node; 649 650 begin 651 With_Clause := First_With_Clause_Of (Project, In_Tree); 652 while Present (With_Clause) loop 653 Imported := Project_Node_Of (With_Clause, In_Tree); 654 655 if Present (Imported) then 656 Declaration := Project_Declaration_Of (Imported, In_Tree); 657 658 if Extended_Project_Of (Declaration, In_Tree) /= 659 Empty_Node 660 then 661 loop 662 Imported := 663 Extended_Project_Of (Declaration, In_Tree); 664 exit when No (Imported); 665 Virtual_Hash.Remove (Imported); 666 Declaration := 667 Project_Declaration_Of (Imported, In_Tree); 668 end loop; 669 end if; 670 end if; 671 672 With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); 673 end loop; 674 end; 675 676 -- Now create all the virtual extending projects 677 678 declare 679 Proj : Project_Node_Id := Empty_Node; 680 Withs : Project_Node_Id; 681 begin 682 Virtual_Hash.Get_First (Proj, Withs); 683 while Withs /= Project_Node_High_Bound loop 684 Create_Virtual_Extending_Project 685 (Proj, Project, Withs, In_Tree); 686 Virtual_Hash.Get_Next (Proj, Withs); 687 end loop; 688 end; 689 end if; 690 691 -- If there were any kind of error during the parsing, serious 692 -- or not, then the parsing fails. 693 694 if Total_Errors_Detected > 0 then 695 Project := Empty_Node; 696 end if; 697 698 case Errout_Handling is 699 when Always_Finalize => 700 Prj.Err.Finalize; 701 702 -- Reinitialize to avoid duplicate warnings later on 703 Prj.Err.Initialize; 704 705 when Finalize_If_Error => 706 if No (Project) then 707 Prj.Err.Finalize; 708 Prj.Err.Initialize; 709 end if; 710 711 when Never_Finalize => 712 null; 713 end case; 714 715 exception 716 when X : others => 717 718 -- Internal error 719 720 Write_Line (Exception_Information (X)); 721 Write_Str ("Exception "); 722 Write_Str (Exception_Name (X)); 723 Write_Line (" raised, while processing project file"); 724 Project := Empty_Node; 725 end Parse; 726 727 ------------------------------ 728 -- Pre_Parse_Context_Clause -- 729 ------------------------------ 730 731 procedure Pre_Parse_Context_Clause 732 (In_Tree : Project_Node_Tree_Ref; 733 Context_Clause : out With_Id; 734 Is_Config_File : Boolean; 735 Flags : Processing_Flags) 736 is 737 Current_With_Clause : With_Id := No_With; 738 Limited_With : Boolean := False; 739 Current_With : With_Record; 740 Current_With_Node : Project_Node_Id := Empty_Node; 741 742 begin 743 -- Assume no context clause 744 745 Context_Clause := No_With; 746 With_Loop : 747 748 -- If Token is not WITH or LIMITED, there is no context clause, or we 749 -- have exhausted the with clauses. 750 751 while Token = Tok_With or else Token = Tok_Limited loop 752 Current_With_Node := 753 Default_Project_Node (Of_Kind => N_With_Clause, In_Tree => In_Tree); 754 Limited_With := Token = Tok_Limited; 755 756 if Is_Config_File then 757 Error_Msg 758 (Flags, 759 "configuration project cannot import " & 760 "other configuration projects", 761 Token_Ptr); 762 end if; 763 764 if Limited_With then 765 Scan (In_Tree); -- past LIMITED 766 Expect (Tok_With, "WITH"); 767 exit With_Loop when Token /= Tok_With; 768 end if; 769 770 Comma_Loop : 771 loop 772 Scan (In_Tree); -- past WITH or "," 773 774 Expect (Tok_String_Literal, "literal string"); 775 776 if Token /= Tok_String_Literal then 777 return; 778 end if; 779 780 -- Store path and location in table Withs 781 782 Current_With := 783 (Path => Path_Name_Type (Token_Name), 784 Location => Token_Ptr, 785 Limited_With => Limited_With, 786 Node => Current_With_Node, 787 Next => No_With); 788 789 Withs.Increment_Last; 790 Withs.Table (Withs.Last) := Current_With; 791 792 if Current_With_Clause = No_With then 793 Context_Clause := Withs.Last; 794 795 else 796 Withs.Table (Current_With_Clause).Next := Withs.Last; 797 end if; 798 799 Current_With_Clause := Withs.Last; 800 801 Scan (In_Tree); 802 803 if Token = Tok_Semicolon then 804 Set_End_Of_Line (Current_With_Node); 805 Set_Previous_Line_Node (Current_With_Node); 806 807 -- End of (possibly multiple) with clause; 808 809 Scan (In_Tree); -- past semicolon 810 exit Comma_Loop; 811 812 elsif Token = Tok_Comma then 813 Set_Is_Not_Last_In_List (Current_With_Node, In_Tree); 814 815 else 816 Error_Msg (Flags, "expected comma or semi colon", Token_Ptr); 817 exit Comma_Loop; 818 end if; 819 820 Current_With_Node := 821 Default_Project_Node 822 (Of_Kind => N_With_Clause, In_Tree => In_Tree); 823 end loop Comma_Loop; 824 end loop With_Loop; 825 end Pre_Parse_Context_Clause; 826 827 ------------------------------- 828 -- Post_Parse_Context_Clause -- 829 ------------------------------- 830 831 procedure Post_Parse_Context_Clause 832 (Context_Clause : With_Id; 833 In_Tree : Project_Node_Tree_Ref; 834 In_Limited : Boolean; 835 Limited_Withs : Boolean; 836 Imported_Projects : in out Project_Node_Id; 837 Project_Directory : Path_Name_Type; 838 From_Extended : Extension_Origin; 839 Packages_To_Check : String_List_Access; 840 Depth : Natural; 841 Current_Dir : String; 842 Is_Config_File : Boolean; 843 Env : in out Environment) 844 is 845 Current_With_Clause : With_Id := Context_Clause; 846 847 Current_Project : Project_Node_Id := Imported_Projects; 848 Previous_Project : Project_Node_Id := Empty_Node; 849 Next_Project : Project_Node_Id := Empty_Node; 850 851 Project_Directory_Path : constant String := 852 Get_Name_String (Project_Directory); 853 854 Current_With : With_Record; 855 Extends_All : Boolean := False; 856 Imported_Path_Name_Id : Path_Name_Type; 857 858 begin 859 -- Set Current_Project to the last project in the current list, if the 860 -- list is not empty. 861 862 if Present (Current_Project) then 863 while 864 Present (Next_With_Clause_Of (Current_Project, In_Tree)) 865 loop 866 Current_Project := Next_With_Clause_Of (Current_Project, In_Tree); 867 end loop; 868 end if; 869 870 while Current_With_Clause /= No_With loop 871 Current_With := Withs.Table (Current_With_Clause); 872 Current_With_Clause := Current_With.Next; 873 874 if Limited_Withs = Current_With.Limited_With then 875 Find_Project 876 (Env.Project_Path, 877 Project_File_Name => Get_Name_String (Current_With.Path), 878 Directory => Project_Directory_Path, 879 Path => Imported_Path_Name_Id); 880 881 if Imported_Path_Name_Id = No_Path then 882 if Env.Flags.Ignore_Missing_With then 883 In_Tree.Incomplete_With := True; 884 885 else 886 -- The project file cannot be found 887 888 Error_Msg_File_1 := File_Name_Type (Current_With.Path); 889 Error_Msg 890 (Env.Flags, "unknown project file: {", 891 Current_With.Location); 892 893 -- If this is not imported by the main project file, display 894 -- the import path. 895 896 if Project_Stack.Last > 1 then 897 for Index in reverse 1 .. Project_Stack.Last loop 898 Error_Msg_File_1 := 899 File_Name_Type 900 (Project_Stack.Table (Index).Path_Name); 901 Error_Msg 902 (Env.Flags, "\imported by {", Current_With.Location); 903 end loop; 904 end if; 905 end if; 906 907 else 908 -- New with clause 909 910 declare 911 Resolved_Path : constant String := 912 Normalize_Pathname 913 (Get_Name_String (Imported_Path_Name_Id), 914 Directory => Current_Dir, 915 Resolve_Links => 916 Opt.Follow_Links_For_Files, 917 Case_Sensitive => True); 918 919 Withed_Project : Project_Node_Id := Empty_Node; 920 921 begin 922 Previous_Project := Current_Project; 923 924 if No (Current_Project) then 925 926 -- First with clause of the context clause 927 928 Current_Project := Current_With.Node; 929 Imported_Projects := Current_Project; 930 931 else 932 Next_Project := Current_With.Node; 933 Set_Next_With_Clause_Of 934 (Current_Project, In_Tree, Next_Project); 935 Current_Project := Next_Project; 936 end if; 937 938 Set_String_Value_Of 939 (Current_Project, 940 In_Tree, 941 Name_Id (Current_With.Path)); 942 Set_Location_Of 943 (Current_Project, In_Tree, Current_With.Location); 944 945 -- If it is a limited with, check if we have a circularity. 946 -- If we have one, get the project id of the limited 947 -- imported project file, and do not parse it. 948 949 if (In_Limited or Limited_Withs) 950 and then Project_Stack.Last > 1 951 then 952 declare 953 Canonical_Path_Name : Path_Name_Type; 954 955 begin 956 Name_Len := Resolved_Path'Length; 957 Name_Buffer (1 .. Name_Len) := Resolved_Path; 958 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); 959 Canonical_Path_Name := Name_Find; 960 961 for Index in 1 .. Project_Stack.Last loop 962 if Project_Stack.Table (Index).Canonical_Path_Name = 963 Canonical_Path_Name 964 then 965 -- We have found the limited imported project, 966 -- get its project id, and do not parse it. 967 968 Withed_Project := Project_Stack.Table (Index).Id; 969 exit; 970 end if; 971 end loop; 972 end; 973 end if; 974 975 -- Parse the imported project if its project id is unknown 976 977 if No (Withed_Project) then 978 Parse_Single_Project 979 (In_Tree => In_Tree, 980 Project => Withed_Project, 981 Extends_All => Extends_All, 982 Path_Name_Id => Imported_Path_Name_Id, 983 Extended => False, 984 From_Extended => From_Extended, 985 In_Limited => In_Limited or Limited_Withs, 986 Packages_To_Check => Packages_To_Check, 987 Depth => Depth, 988 Current_Dir => Current_Dir, 989 Is_Config_File => Is_Config_File, 990 Env => Env); 991 992 else 993 Extends_All := Is_Extending_All (Withed_Project, In_Tree); 994 end if; 995 996 if No (Withed_Project) then 997 998 -- If parsing unsuccessful, remove the context clause 999 1000 Current_Project := Previous_Project; 1001 1002 if No (Current_Project) then 1003 Imported_Projects := Empty_Node; 1004 1005 else 1006 Set_Next_With_Clause_Of 1007 (Current_Project, In_Tree, Empty_Node); 1008 end if; 1009 else 1010 -- If parsing was successful, record project name and 1011 -- path name in with clause 1012 1013 Set_Project_Node_Of 1014 (Node => Current_Project, 1015 In_Tree => In_Tree, 1016 To => Withed_Project, 1017 Limited_With => Current_With.Limited_With); 1018 Set_Name_Of 1019 (Current_Project, 1020 In_Tree, 1021 Name_Of (Withed_Project, In_Tree)); 1022 1023 Name_Len := Resolved_Path'Length; 1024 Name_Buffer (1 .. Name_Len) := Resolved_Path; 1025 Set_Path_Name_Of (Current_Project, In_Tree, Name_Find); 1026 1027 if Extends_All then 1028 Set_Is_Extending_All (Current_Project, In_Tree); 1029 end if; 1030 end if; 1031 end; 1032 end if; 1033 end if; 1034 end loop; 1035 end Post_Parse_Context_Clause; 1036 1037 --------------------------------- 1038 -- Check_Extending_All_Imports -- 1039 --------------------------------- 1040 1041 procedure Check_Extending_All_Imports 1042 (Flags : Processing_Flags; 1043 In_Tree : Project_Node_Tree_Ref; 1044 Project : Project_Node_Id) 1045 is 1046 With_Clause : Project_Node_Id; 1047 Imported : Project_Node_Id; 1048 1049 begin 1050 if not Is_Extending_All (Project, In_Tree) then 1051 With_Clause := First_With_Clause_Of (Project, In_Tree); 1052 while Present (With_Clause) loop 1053 Imported := Project_Node_Of (With_Clause, In_Tree); 1054 1055 if Is_Extending_All (With_Clause, In_Tree) then 1056 Error_Msg_Name_1 := Name_Of (Imported, In_Tree); 1057 Error_Msg (Flags, "cannot import extending-all project %%", 1058 Token_Ptr); 1059 exit; 1060 end if; 1061 1062 With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); 1063 end loop; 1064 end if; 1065 end Check_Extending_All_Imports; 1066 1067 ----------------------------- 1068 -- Check_Aggregate_Imports -- 1069 ----------------------------- 1070 1071 procedure Check_Aggregate_Imports 1072 (Flags : Processing_Flags; 1073 In_Tree : Project_Node_Tree_Ref; 1074 Project : Project_Node_Id) 1075 is 1076 With_Clause, Imported : Project_Node_Id; 1077 begin 1078 if Project_Qualifier_Of (Project, In_Tree) = Aggregate then 1079 With_Clause := First_With_Clause_Of (Project, In_Tree); 1080 1081 while Present (With_Clause) loop 1082 Imported := Project_Node_Of (With_Clause, In_Tree); 1083 1084 if Project_Qualifier_Of (Imported, In_Tree) /= Dry then 1085 Error_Msg_Name_1 := Name_Id (Path_Name_Of (Imported, In_Tree)); 1086 Error_Msg (Flags, "can only import abstract projects, not %%", 1087 Token_Ptr); 1088 exit; 1089 end if; 1090 1091 With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); 1092 end loop; 1093 end if; 1094 end Check_Aggregate_Imports; 1095 1096 ---------------------------- 1097 -- Read_Project_Qualifier -- 1098 ---------------------------- 1099 1100 procedure Read_Project_Qualifier 1101 (Flags : Processing_Flags; 1102 In_Tree : Project_Node_Tree_Ref; 1103 Is_Config_File : Boolean; 1104 Qualifier_Location : out Source_Ptr; 1105 Project : Project_Node_Id) 1106 is 1107 Proj_Qualifier : Project_Qualifier := Unspecified; 1108 begin 1109 Qualifier_Location := Token_Ptr; 1110 1111 if Token = Tok_Abstract then 1112 Proj_Qualifier := Dry; 1113 Scan (In_Tree); 1114 1115 elsif Token = Tok_Identifier then 1116 case Token_Name is 1117 when Snames.Name_Standard => 1118 Proj_Qualifier := Standard; 1119 Scan (In_Tree); 1120 1121 when Snames.Name_Aggregate => 1122 Proj_Qualifier := Aggregate; 1123 Scan (In_Tree); 1124 1125 if Token = Tok_Identifier 1126 and then Token_Name = Snames.Name_Library 1127 then 1128 Proj_Qualifier := Aggregate_Library; 1129 Scan (In_Tree); 1130 end if; 1131 1132 when Snames.Name_Library => 1133 Proj_Qualifier := Library; 1134 Scan (In_Tree); 1135 1136 when Snames.Name_Configuration => 1137 if not Is_Config_File then 1138 Error_Msg 1139 (Flags, 1140 "configuration projects cannot belong to a user" & 1141 " project tree", 1142 Token_Ptr); 1143 end if; 1144 1145 Proj_Qualifier := Configuration; 1146 Scan (In_Tree); 1147 1148 when others => 1149 null; 1150 end case; 1151 end if; 1152 1153 if Is_Config_File and then Proj_Qualifier = Unspecified then 1154 1155 -- Set the qualifier to Configuration, even if the token doesn't 1156 -- exist in the source file itself, so that we can differentiate 1157 -- project files and configuration files later on. 1158 1159 Proj_Qualifier := Configuration; 1160 end if; 1161 1162 if Proj_Qualifier /= Unspecified then 1163 if Is_Config_File 1164 and then Proj_Qualifier /= Configuration 1165 then 1166 Error_Msg (Flags, 1167 "a configuration project cannot be qualified except " & 1168 "as configuration project", 1169 Qualifier_Location); 1170 end if; 1171 1172 Set_Project_Qualifier_Of (Project, In_Tree, Proj_Qualifier); 1173 end if; 1174 end Read_Project_Qualifier; 1175 1176 ------------------------------- 1177 -- Has_Circular_Dependencies -- 1178 ------------------------------- 1179 1180 function Has_Circular_Dependencies 1181 (Flags : Processing_Flags; 1182 Normed_Path_Name : Path_Name_Type; 1183 Canonical_Path_Name : Path_Name_Type) return Boolean is 1184 begin 1185 for Index in reverse 1 .. Project_Stack.Last loop 1186 exit when Project_Stack.Table (Index).Limited_With; 1187 1188 if Canonical_Path_Name = 1189 Project_Stack.Table (Index).Canonical_Path_Name 1190 then 1191 Error_Msg (Flags, "circular dependency detected", Token_Ptr); 1192 Error_Msg_Name_1 := Name_Id (Normed_Path_Name); 1193 Error_Msg (Flags, "\ %% is imported by", Token_Ptr); 1194 1195 for Current in reverse 1 .. Project_Stack.Last loop 1196 Error_Msg_Name_1 := 1197 Name_Id (Project_Stack.Table (Current).Path_Name); 1198 1199 if Project_Stack.Table (Current).Canonical_Path_Name /= 1200 Canonical_Path_Name 1201 then 1202 Error_Msg 1203 (Flags, "\ %% which itself is imported by", Token_Ptr); 1204 1205 else 1206 Error_Msg (Flags, "\ %%", Token_Ptr); 1207 exit; 1208 end if; 1209 end loop; 1210 1211 return True; 1212 end if; 1213 end loop; 1214 return False; 1215 end Has_Circular_Dependencies; 1216 1217 -------------------------- 1218 -- Parse_Single_Project -- 1219 -------------------------- 1220 1221 procedure Parse_Single_Project 1222 (In_Tree : Project_Node_Tree_Ref; 1223 Project : out Project_Node_Id; 1224 Extends_All : out Boolean; 1225 Path_Name_Id : Path_Name_Type; 1226 Extended : Boolean; 1227 From_Extended : Extension_Origin; 1228 In_Limited : Boolean; 1229 Packages_To_Check : String_List_Access; 1230 Depth : Natural; 1231 Current_Dir : String; 1232 Is_Config_File : Boolean; 1233 Env : in out Environment) 1234 is 1235 Path_Name : constant String := Get_Name_String (Path_Name_Id); 1236 1237 Normed_Path_Name : Path_Name_Type; 1238 Canonical_Path_Name : Path_Name_Type; 1239 Project_Directory : Path_Name_Type; 1240 Project_Scan_State : Saved_Project_Scan_State; 1241 Source_Index : Source_File_Index; 1242 1243 Extending : Boolean := False; 1244 1245 Extended_Project : Project_Node_Id := Empty_Node; 1246 1247 A_Project_Name_And_Node : Tree_Private_Part.Project_Name_And_Node := 1248 Tree_Private_Part.Projects_Htable.Get_First 1249 (In_Tree.Projects_HT); 1250 1251 Name_From_Path : constant Name_Id := 1252 Project_Name_From (Path_Name, Is_Config_File => Is_Config_File); 1253 Name_Of_Project : Name_Id := No_Name; 1254 Display_Name_Of_Project : Name_Id := No_Name; 1255 1256 Duplicated : Boolean := False; 1257 1258 First_With : With_Id; 1259 Imported_Projects : Project_Node_Id := Empty_Node; 1260 1261 use Tree_Private_Part; 1262 1263 Project_Comment_State : Tree.Comment_State; 1264 1265 Qualifier_Location : Source_Ptr; 1266 1267 begin 1268 Extends_All := False; 1269 1270 declare 1271 Normed_Path : constant String := Normalize_Pathname 1272 (Path_Name, 1273 Directory => Current_Dir, 1274 Resolve_Links => False, 1275 Case_Sensitive => True); 1276 Canonical_Path : constant String := Normalize_Pathname 1277 (Normed_Path, 1278 Directory => Current_Dir, 1279 Resolve_Links => Opt.Follow_Links_For_Files, 1280 Case_Sensitive => False); 1281 begin 1282 Name_Len := Normed_Path'Length; 1283 Name_Buffer (1 .. Name_Len) := Normed_Path; 1284 Normed_Path_Name := Name_Find; 1285 Name_Len := Canonical_Path'Length; 1286 Name_Buffer (1 .. Name_Len) := Canonical_Path; 1287 Canonical_Path_Name := Name_Find; 1288 end; 1289 1290 if Has_Circular_Dependencies 1291 (Env.Flags, Normed_Path_Name, Canonical_Path_Name) 1292 then 1293 Project := Empty_Node; 1294 return; 1295 end if; 1296 1297 -- Put the new path name on the stack 1298 1299 Project_Stack.Append 1300 ((Path_Name => Normed_Path_Name, 1301 Canonical_Path_Name => Canonical_Path_Name, 1302 Id => Empty_Node, 1303 Limited_With => In_Limited)); 1304 1305 -- Check if the project file has already been parsed 1306 1307 while 1308 A_Project_Name_And_Node /= Tree_Private_Part.No_Project_Name_And_Node 1309 loop 1310 if A_Project_Name_And_Node.Canonical_Path = Canonical_Path_Name then 1311 if Extended then 1312 1313 if A_Project_Name_And_Node.Extended then 1314 if A_Project_Name_And_Node.Proj_Qualifier /= Dry then 1315 Error_Msg 1316 (Env.Flags, 1317 "cannot extend the same project file several times", 1318 Token_Ptr); 1319 end if; 1320 else 1321 Error_Msg 1322 (Env.Flags, 1323 "cannot extend an already imported project file", 1324 Token_Ptr); 1325 end if; 1326 1327 elsif A_Project_Name_And_Node.Extended then 1328 Extends_All := 1329 Is_Extending_All (A_Project_Name_And_Node.Node, In_Tree); 1330 1331 -- If the imported project is an extended project A, and we are 1332 -- in an extended project, replace A with the ultimate project 1333 -- extending A. 1334 1335 if From_Extended /= None then 1336 declare 1337 Decl : Project_Node_Id := 1338 Project_Declaration_Of 1339 (A_Project_Name_And_Node.Node, In_Tree); 1340 1341 Prj : Project_Node_Id := 1342 A_Project_Name_And_Node.Node; 1343 1344 begin 1345 -- Loop through extending projects to find the ultimate 1346 -- extending project, that is the one that is not 1347 -- extended. For an abstract project, as it can be 1348 -- extended several times, there is no extending project 1349 -- registered, so the loop does not execute and the 1350 -- resulting project is the abstract project. 1351 1352 while 1353 Extending_Project_Of (Decl, In_Tree) /= Empty_Node 1354 loop 1355 Prj := Extending_Project_Of (Decl, In_Tree); 1356 Decl := Project_Declaration_Of (Prj, In_Tree); 1357 end loop; 1358 1359 A_Project_Name_And_Node.Node := Prj; 1360 end; 1361 else 1362 Error_Msg 1363 (Env.Flags, 1364 "cannot import an already extended project file", 1365 Token_Ptr); 1366 end if; 1367 end if; 1368 1369 Project := A_Project_Name_And_Node.Node; 1370 Project_Stack.Decrement_Last; 1371 return; 1372 end if; 1373 1374 A_Project_Name_And_Node := 1375 Tree_Private_Part.Projects_Htable.Get_Next (In_Tree.Projects_HT); 1376 end loop; 1377 1378 -- We never encountered this project file. Save the scan state, load the 1379 -- project file and start to scan it. 1380 1381 Save_Project_Scan_State (Project_Scan_State); 1382 Source_Index := Load_Project_File (Path_Name); 1383 Tree.Save (Project_Comment_State); 1384 1385 -- If we cannot find it, we stop 1386 1387 if Source_Index = No_Source_File then 1388 Project := Empty_Node; 1389 Project_Stack.Decrement_Last; 1390 return; 1391 end if; 1392 1393 Prj.Err.Scanner.Initialize_Scanner (Source_Index); 1394 Tree.Reset_State; 1395 Scan (In_Tree); 1396 1397 if not Is_Config_File and then Name_From_Path = No_Name then 1398 1399 -- The project file name is not correct (no or bad extension, or not 1400 -- following Ada identifier's syntax). 1401 1402 Error_Msg_File_1 := File_Name_Type (Canonical_Path_Name); 1403 Error_Msg (Env.Flags, 1404 "?{ is not a valid path name for a project file", 1405 Token_Ptr); 1406 end if; 1407 1408 if Current_Verbosity >= Medium then 1409 Debug_Increase_Indent ("Parsing """ & Path_Name & '"'); 1410 end if; 1411 1412 Project_Directory := 1413 Path_Name_Type (Get_Directory (File_Name_Type (Normed_Path_Name))); 1414 1415 -- Is there any imported project? 1416 1417 Pre_Parse_Context_Clause 1418 (In_Tree => In_Tree, 1419 Is_Config_File => Is_Config_File, 1420 Context_Clause => First_With, 1421 Flags => Env.Flags); 1422 1423 Project := Default_Project_Node 1424 (Of_Kind => N_Project, In_Tree => In_Tree); 1425 Project_Stack.Table (Project_Stack.Last).Id := Project; 1426 Set_Directory_Of (Project, In_Tree, Project_Directory); 1427 Set_Path_Name_Of (Project, In_Tree, Normed_Path_Name); 1428 1429 Read_Project_Qualifier 1430 (Env.Flags, In_Tree, Is_Config_File, Qualifier_Location, Project); 1431 1432 Set_Location_Of (Project, In_Tree, Token_Ptr); 1433 1434 Expect (Tok_Project, "PROJECT"); 1435 1436 -- Mark location of PROJECT token if present 1437 1438 if Token = Tok_Project then 1439 Scan (In_Tree); -- past PROJECT 1440 Set_Location_Of (Project, In_Tree, Token_Ptr); 1441 end if; 1442 1443 -- Clear the Buffer 1444 1445 Buffer_Last := 0; 1446 loop 1447 Expect (Tok_Identifier, "identifier"); 1448 1449 -- If the token is not an identifier, clear the buffer before 1450 -- exiting to indicate that the name of the project is ill-formed. 1451 1452 if Token /= Tok_Identifier then 1453 Buffer_Last := 0; 1454 exit; 1455 end if; 1456 1457 -- Add the identifier name to the buffer 1458 1459 Get_Name_String (Token_Name); 1460 Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last); 1461 1462 -- Scan past the identifier 1463 1464 Scan (In_Tree); 1465 1466 -- If we have a dot, add a dot to the Buffer and look for the next 1467 -- identifier. 1468 1469 exit when Token /= Tok_Dot; 1470 Add_To_Buffer (".", Buffer, Buffer_Last); 1471 1472 -- Scan past the dot 1473 1474 Scan (In_Tree); 1475 end loop; 1476 1477 -- See if this is an extending project 1478 1479 if Token = Tok_Extends then 1480 1481 if Is_Config_File then 1482 Error_Msg 1483 (Env.Flags, 1484 "extending configuration project not allowed", Token_Ptr); 1485 end if; 1486 1487 -- Make sure that gnatmake will use mapping files 1488 1489 Opt.Create_Mapping_File := True; 1490 1491 -- We are extending another project 1492 1493 Extending := True; 1494 1495 Scan (In_Tree); -- past EXTENDS 1496 1497 if Token = Tok_All then 1498 Extends_All := True; 1499 Set_Is_Extending_All (Project, In_Tree); 1500 Scan (In_Tree); -- scan past ALL 1501 end if; 1502 end if; 1503 1504 -- If the name is well formed, Buffer_Last is > 0 1505 1506 if Buffer_Last > 0 then 1507 1508 -- The Buffer contains the name of the project 1509 1510 Name_Len := Buffer_Last; 1511 Name_Buffer (1 .. Name_Len) := Buffer (1 .. Buffer_Last); 1512 Name_Of_Project := Name_Find; 1513 Set_Name_Of (Project, In_Tree, Name_Of_Project); 1514 1515 -- To get expected name of the project file, replace dots by dashes 1516 1517 for Index in 1 .. Name_Len loop 1518 if Name_Buffer (Index) = '.' then 1519 Name_Buffer (Index) := '-'; 1520 end if; 1521 end loop; 1522 1523 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); 1524 1525 declare 1526 Expected_Name : constant Name_Id := Name_Find; 1527 Extension : String_Access; 1528 1529 begin 1530 -- Output a warning if the actual name is not the expected name 1531 1532 if not Is_Config_File 1533 and then (Name_From_Path /= No_Name) 1534 and then Expected_Name /= Name_From_Path 1535 then 1536 Error_Msg_Name_1 := Expected_Name; 1537 1538 if Is_Config_File then 1539 Extension := new String'(Config_Project_File_Extension); 1540 1541 else 1542 Extension := new String'(Project_File_Extension); 1543 end if; 1544 1545 Error_Msg 1546 (Env.Flags, 1547 "?file name does not match project name, should be `%%" 1548 & Extension.all & "`", 1549 Token_Ptr); 1550 end if; 1551 end; 1552 1553 -- Read the original casing of the project name 1554 1555 declare 1556 Loc : Source_Ptr; 1557 1558 begin 1559 Loc := Location_Of (Project, In_Tree); 1560 for J in 1 .. Name_Len loop 1561 Name_Buffer (J) := Sinput.Source (Loc); 1562 Loc := Loc + 1; 1563 end loop; 1564 1565 Display_Name_Of_Project := Name_Find; 1566 end; 1567 1568 declare 1569 From_Ext : Extension_Origin := None; 1570 1571 begin 1572 -- Extending_All is always propagated 1573 1574 if From_Extended = Extending_All or else Extends_All then 1575 From_Ext := Extending_All; 1576 1577 -- Otherwise, From_Extended is set to Extending_Single if the 1578 -- current project is an extending project. 1579 1580 elsif Extended then 1581 From_Ext := Extending_Simple; 1582 end if; 1583 1584 Post_Parse_Context_Clause 1585 (In_Tree => In_Tree, 1586 Context_Clause => First_With, 1587 In_Limited => In_Limited, 1588 Limited_Withs => False, 1589 Imported_Projects => Imported_Projects, 1590 Project_Directory => Project_Directory, 1591 From_Extended => From_Ext, 1592 Packages_To_Check => Packages_To_Check, 1593 Depth => Depth + 1, 1594 Current_Dir => Current_Dir, 1595 Is_Config_File => Is_Config_File, 1596 Env => Env); 1597 Set_First_With_Clause_Of (Project, In_Tree, Imported_Projects); 1598 end; 1599 1600 if not Is_Config_File then 1601 declare 1602 Name_And_Node : Tree_Private_Part.Project_Name_And_Node := 1603 Tree_Private_Part.Projects_Htable.Get_First 1604 (In_Tree.Projects_HT); 1605 Project_Name : Name_Id := Name_And_Node.Name; 1606 1607 begin 1608 -- Check if we already have a project with this name 1609 1610 while Project_Name /= No_Name 1611 and then Project_Name /= Name_Of_Project 1612 loop 1613 Name_And_Node := 1614 Tree_Private_Part.Projects_Htable.Get_Next 1615 (In_Tree.Projects_HT); 1616 Project_Name := Name_And_Node.Name; 1617 end loop; 1618 1619 -- Report an error if we already have a project with this name 1620 1621 if Project_Name /= No_Name then 1622 Duplicated := True; 1623 Error_Msg_Name_1 := Project_Name; 1624 Error_Msg 1625 (Env.Flags, "duplicate project name %%", 1626 Location_Of (Project, In_Tree)); 1627 Error_Msg_Name_1 := 1628 Name_Id (Path_Name_Of (Name_And_Node.Node, In_Tree)); 1629 Error_Msg 1630 (Env.Flags, 1631 "\already in %%", Location_Of (Project, In_Tree)); 1632 end if; 1633 end; 1634 end if; 1635 1636 end if; 1637 1638 if Extending then 1639 Expect (Tok_String_Literal, "literal string"); 1640 1641 if Token = Tok_String_Literal then 1642 Set_Extended_Project_Path_Of 1643 (Project, 1644 In_Tree, 1645 Path_Name_Type (Token_Name)); 1646 1647 declare 1648 Original_Path_Name : constant String := 1649 Get_Name_String (Token_Name); 1650 1651 Extended_Project_Path_Name_Id : Path_Name_Type; 1652 1653 begin 1654 Find_Project 1655 (Env.Project_Path, 1656 Project_File_Name => Original_Path_Name, 1657 Directory => Get_Name_String (Project_Directory), 1658 Path => Extended_Project_Path_Name_Id); 1659 1660 if Extended_Project_Path_Name_Id = No_Path then 1661 1662 -- We could not find the project file to extend 1663 1664 Error_Msg_Name_1 := Token_Name; 1665 1666 Error_Msg (Env.Flags, "unknown project file: %%", Token_Ptr); 1667 1668 -- If not in the main project file, display the import path 1669 1670 if Project_Stack.Last > 1 then 1671 Error_Msg_Name_1 := 1672 Name_Id 1673 (Project_Stack.Table (Project_Stack.Last).Path_Name); 1674 Error_Msg (Env.Flags, "\extended by %%", Token_Ptr); 1675 1676 for Index in reverse 1 .. Project_Stack.Last - 1 loop 1677 Error_Msg_Name_1 := 1678 Name_Id 1679 (Project_Stack.Table (Index).Path_Name); 1680 Error_Msg (Env.Flags, "\imported by %%", Token_Ptr); 1681 end loop; 1682 end if; 1683 1684 else 1685 declare 1686 From_Ext : Extension_Origin := None; 1687 1688 begin 1689 if From_Extended = Extending_All or else Extends_All then 1690 From_Ext := Extending_All; 1691 end if; 1692 1693 Parse_Single_Project 1694 (In_Tree => In_Tree, 1695 Project => Extended_Project, 1696 Extends_All => Extends_All, 1697 Path_Name_Id => Extended_Project_Path_Name_Id, 1698 Extended => True, 1699 From_Extended => From_Ext, 1700 In_Limited => In_Limited, 1701 Packages_To_Check => Packages_To_Check, 1702 Depth => Depth + 1, 1703 Current_Dir => Current_Dir, 1704 Is_Config_File => Is_Config_File, 1705 Env => Env); 1706 end; 1707 1708 if Present (Extended_Project) then 1709 1710 -- A project that extends an extending-all project is 1711 -- also an extending-all project. 1712 1713 if Is_Extending_All (Extended_Project, In_Tree) then 1714 Set_Is_Extending_All (Project, In_Tree); 1715 end if; 1716 1717 -- An abstract project can only extend an abstract 1718 -- project. Otherwise we may have an abstract project 1719 -- with sources if it inherits sources from the project 1720 -- it extends. 1721 1722 if Project_Qualifier_Of (Project, In_Tree) = Dry and then 1723 Project_Qualifier_Of (Extended_Project, In_Tree) /= Dry 1724 then 1725 Error_Msg 1726 (Env.Flags, "an abstract project can only extend " & 1727 "another abstract project", 1728 Qualifier_Location); 1729 end if; 1730 end if; 1731 end if; 1732 end; 1733 1734 Scan (In_Tree); -- past the extended project path 1735 end if; 1736 end if; 1737 1738 Check_Extending_All_Imports (Env.Flags, In_Tree, Project); 1739 Check_Aggregate_Imports (Env.Flags, In_Tree, Project); 1740 1741 -- Check that a project with a name including a dot either imports 1742 -- or extends the project whose name precedes the last dot. 1743 1744 if Name_Of_Project /= No_Name then 1745 Get_Name_String (Name_Of_Project); 1746 1747 else 1748 Name_Len := 0; 1749 end if; 1750 1751 -- Look for the last dot 1752 1753 while Name_Len > 0 and then Name_Buffer (Name_Len) /= '.' loop 1754 Name_Len := Name_Len - 1; 1755 end loop; 1756 1757 -- If a dot was found, check if parent project is imported or extended 1758 1759 if Name_Len > 0 then 1760 Name_Len := Name_Len - 1; 1761 1762 declare 1763 Parent_Name : constant Name_Id := Name_Find; 1764 Parent_Found : Boolean := False; 1765 Parent_Node : Project_Node_Id := Empty_Node; 1766 With_Clause : Project_Node_Id := 1767 First_With_Clause_Of (Project, In_Tree); 1768 Imp_Proj_Name : Name_Id; 1769 1770 begin 1771 -- If there is an extended project, check its name 1772 1773 if Present (Extended_Project) then 1774 Parent_Node := Extended_Project; 1775 Parent_Found := 1776 Name_Of (Extended_Project, In_Tree) = Parent_Name; 1777 end if; 1778 1779 -- If the parent project is not the extended project, 1780 -- check each imported project until we find the parent project. 1781 1782 Imported_Loop : 1783 while not Parent_Found and then Present (With_Clause) loop 1784 Parent_Node := Project_Node_Of (With_Clause, In_Tree); 1785 Extension_Loop : while Present (Parent_Node) loop 1786 Imp_Proj_Name := Name_Of (Parent_Node, In_Tree); 1787 Parent_Found := Imp_Proj_Name = Parent_Name; 1788 exit Imported_Loop when Parent_Found; 1789 Parent_Node := 1790 Extended_Project_Of 1791 (Project_Declaration_Of (Parent_Node, In_Tree), 1792 In_Tree); 1793 end loop Extension_Loop; 1794 1795 With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); 1796 end loop Imported_Loop; 1797 1798 if Parent_Found then 1799 Set_Parent_Project_Of (Project, In_Tree, To => Parent_Node); 1800 1801 else 1802 -- If the parent project was not found, report an error 1803 1804 Error_Msg_Name_1 := Name_Of_Project; 1805 Error_Msg_Name_2 := Parent_Name; 1806 Error_Msg (Env.Flags, 1807 "project %% does not import or extend project %%", 1808 Location_Of (Project, In_Tree)); 1809 end if; 1810 end; 1811 end if; 1812 1813 Expect (Tok_Is, "IS"); 1814 Set_End_Of_Line (Project); 1815 Set_Previous_Line_Node (Project); 1816 Set_Next_End_Node (Project); 1817 1818 declare 1819 Project_Declaration : Project_Node_Id := Empty_Node; 1820 1821 begin 1822 -- No need to Scan past "is", Prj.Dect.Parse will do it 1823 1824 Prj.Dect.Parse 1825 (In_Tree => In_Tree, 1826 Declarations => Project_Declaration, 1827 Current_Project => Project, 1828 Extends => Extended_Project, 1829 Packages_To_Check => Packages_To_Check, 1830 Is_Config_File => Is_Config_File, 1831 Flags => Env.Flags); 1832 Set_Project_Declaration_Of (Project, In_Tree, Project_Declaration); 1833 1834 if Present (Extended_Project) 1835 and then Project_Qualifier_Of (Extended_Project, In_Tree) /= Dry 1836 then 1837 Set_Extending_Project_Of 1838 (Project_Declaration_Of (Extended_Project, In_Tree), In_Tree, 1839 To => Project); 1840 end if; 1841 end; 1842 1843 Expect (Tok_End, "END"); 1844 Remove_Next_End_Node; 1845 1846 -- Skip "end" if present 1847 1848 if Token = Tok_End then 1849 Scan (In_Tree); 1850 end if; 1851 1852 -- Clear the Buffer 1853 1854 Buffer_Last := 0; 1855 1856 -- Store the name following "end" in the Buffer. The name may be made of 1857 -- several simple names. 1858 1859 loop 1860 Expect (Tok_Identifier, "identifier"); 1861 1862 -- If we don't have an identifier, clear the buffer before exiting to 1863 -- avoid checking the name. 1864 1865 if Token /= Tok_Identifier then 1866 Buffer_Last := 0; 1867 exit; 1868 end if; 1869 1870 -- Add the identifier to the Buffer 1871 Get_Name_String (Token_Name); 1872 Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last); 1873 1874 -- Scan past the identifier 1875 1876 Scan (In_Tree); 1877 exit when Token /= Tok_Dot; 1878 Add_To_Buffer (".", Buffer, Buffer_Last); 1879 Scan (In_Tree); 1880 end loop; 1881 1882 -- If we have a valid name, check if it is the name of the project 1883 1884 if Name_Of_Project /= No_Name and then Buffer_Last > 0 then 1885 if To_Lower (Buffer (1 .. Buffer_Last)) /= 1886 Get_Name_String (Name_Of (Project, In_Tree)) 1887 then 1888 -- Invalid name: report an error 1889 1890 Error_Msg (Env.Flags, "expected """ & 1891 Get_Name_String (Name_Of (Project, In_Tree)) & """", 1892 Token_Ptr); 1893 end if; 1894 end if; 1895 1896 Expect (Tok_Semicolon, "`;`"); 1897 1898 -- Check that there is no more text following the end of the project 1899 -- source. 1900 1901 if Token = Tok_Semicolon then 1902 Set_Previous_End_Node (Project); 1903 Scan (In_Tree); 1904 1905 if Token /= Tok_EOF then 1906 Error_Msg 1907 (Env.Flags, 1908 "unexpected text following end of project", Token_Ptr); 1909 end if; 1910 end if; 1911 1912 if not Duplicated and then Name_Of_Project /= No_Name then 1913 1914 -- Add the name of the project to the hash table, so that we can 1915 -- check that no other subsequent project will have the same name. 1916 1917 Tree_Private_Part.Projects_Htable.Set 1918 (T => In_Tree.Projects_HT, 1919 K => Name_Of_Project, 1920 E => (Name => Name_Of_Project, 1921 Display_Name => Display_Name_Of_Project, 1922 Node => Project, 1923 Canonical_Path => Canonical_Path_Name, 1924 Extended => Extended, 1925 Proj_Qualifier => Project_Qualifier_Of (Project, In_Tree))); 1926 end if; 1927 1928 declare 1929 From_Ext : Extension_Origin := None; 1930 1931 begin 1932 -- Extending_All is always propagated 1933 1934 if From_Extended = Extending_All or else Extends_All then 1935 From_Ext := Extending_All; 1936 1937 -- Otherwise, From_Extended is set to Extending_Single if the 1938 -- current project is an extending project. 1939 1940 elsif Extended then 1941 From_Ext := Extending_Simple; 1942 end if; 1943 1944 Post_Parse_Context_Clause 1945 (In_Tree => In_Tree, 1946 Context_Clause => First_With, 1947 In_Limited => In_Limited, 1948 Limited_Withs => True, 1949 Imported_Projects => Imported_Projects, 1950 Project_Directory => Project_Directory, 1951 From_Extended => From_Ext, 1952 Packages_To_Check => Packages_To_Check, 1953 Depth => Depth + 1, 1954 Current_Dir => Current_Dir, 1955 Is_Config_File => Is_Config_File, 1956 Env => Env); 1957 Set_First_With_Clause_Of (Project, In_Tree, Imported_Projects); 1958 end; 1959 1960 -- Restore the scan state, in case we are not the main project 1961 1962 Restore_Project_Scan_State (Project_Scan_State); 1963 1964 -- And remove the project from the project stack 1965 1966 Project_Stack.Decrement_Last; 1967 1968 -- Indicate if there are unkept comments 1969 1970 Tree.Set_Project_File_Includes_Unkept_Comments 1971 (Node => Project, 1972 In_Tree => In_Tree, 1973 To => Tree.There_Are_Unkept_Comments); 1974 1975 -- And restore the comment state that was saved 1976 1977 Tree.Restore_And_Free (Project_Comment_State); 1978 1979 Debug_Decrease_Indent; 1980 end Parse_Single_Project; 1981 1982 ----------------------- 1983 -- Project_Name_From -- 1984 ----------------------- 1985 1986 function Project_Name_From 1987 (Path_Name : String; 1988 Is_Config_File : Boolean) return Name_Id 1989 is 1990 Canonical : String (1 .. Path_Name'Length) := Path_Name; 1991 First : Natural := Canonical'Last; 1992 Last : Natural := First; 1993 Index : Positive; 1994 1995 begin 1996 if Current_Verbosity = High then 1997 Debug_Output ("Project_Name_From (""" & Canonical & """)"); 1998 end if; 1999 2000 -- If the path name is empty, return No_Name to indicate failure 2001 2002 if First = 0 then 2003 return No_Name; 2004 end if; 2005 2006 Canonical_Case_File_Name (Canonical); 2007 2008 -- Look for the last dot in the path name 2009 2010 while First > 0 2011 and then 2012 Canonical (First) /= '.' 2013 loop 2014 First := First - 1; 2015 end loop; 2016 2017 -- If we have a dot, check that it is followed by the correct extension 2018 2019 if First > 0 and then Canonical (First) = '.' then 2020 if (not Is_Config_File 2021 and then Canonical (First .. Last) = Project_File_Extension 2022 and then First /= 1) 2023 or else 2024 (Is_Config_File 2025 and then 2026 Canonical (First .. Last) = Config_Project_File_Extension 2027 and then First /= 1) 2028 then 2029 -- Look for the last directory separator, if any 2030 2031 First := First - 1; 2032 Last := First; 2033 while First > 0 2034 and then Canonical (First) /= '/' 2035 and then Canonical (First) /= Dir_Sep 2036 loop 2037 First := First - 1; 2038 end loop; 2039 2040 else 2041 -- Not the correct extension, return No_Name to indicate failure 2042 2043 return No_Name; 2044 end if; 2045 2046 -- If no dot in the path name, return No_Name to indicate failure 2047 2048 else 2049 return No_Name; 2050 end if; 2051 2052 First := First + 1; 2053 2054 -- If the extension is the file name, return No_Name to indicate failure 2055 2056 if First > Last then 2057 return No_Name; 2058 end if; 2059 2060 -- Put the name in lower case into Name_Buffer 2061 2062 Name_Len := Last - First + 1; 2063 Name_Buffer (1 .. Name_Len) := To_Lower (Canonical (First .. Last)); 2064 2065 Index := 1; 2066 2067 -- Check if it is a well formed project name. Return No_Name if it is 2068 -- ill formed. 2069 2070 loop 2071 if not Is_Letter (Name_Buffer (Index)) then 2072 return No_Name; 2073 2074 else 2075 loop 2076 Index := Index + 1; 2077 2078 exit when Index >= Name_Len; 2079 2080 if Name_Buffer (Index) = '_' then 2081 if Name_Buffer (Index + 1) = '_' then 2082 return No_Name; 2083 end if; 2084 end if; 2085 2086 exit when Name_Buffer (Index) = '-'; 2087 2088 if Name_Buffer (Index) /= '_' 2089 and then not Is_Alphanumeric (Name_Buffer (Index)) 2090 then 2091 return No_Name; 2092 end if; 2093 2094 end loop; 2095 end if; 2096 2097 if Index >= Name_Len then 2098 if Is_Alphanumeric (Name_Buffer (Name_Len)) then 2099 2100 -- All checks have succeeded. Return name in Name_Buffer 2101 2102 return Name_Find; 2103 2104 else 2105 return No_Name; 2106 end if; 2107 2108 elsif Name_Buffer (Index) = '-' then 2109 Index := Index + 1; 2110 end if; 2111 end loop; 2112 end Project_Name_From; 2113 2114end Prj.Part; 2115