1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- P R J . N M S C -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2000-2015, 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 Err_Vars; use Err_Vars; 27with Opt; use Opt; 28with Osint; use Osint; 29with Output; use Output; 30with Prj.Com; 31with Prj.Env; use Prj.Env; 32with Prj.Err; use Prj.Err; 33with Prj.Tree; use Prj.Tree; 34with Prj.Util; use Prj.Util; 35with Sinput.P; 36with Snames; use Snames; 37 38with Ada; use Ada; 39with Ada.Characters.Handling; use Ada.Characters.Handling; 40with Ada.Directories; use Ada.Directories; 41with Ada.Strings; use Ada.Strings; 42with Ada.Strings.Fixed; use Ada.Strings.Fixed; 43with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants; 44 45with GNAT.Case_Util; use GNAT.Case_Util; 46with GNAT.Directory_Operations; use GNAT.Directory_Operations; 47with GNAT.Dynamic_HTables; 48with GNAT.Regexp; use GNAT.Regexp; 49with GNAT.Table; 50 51package body Prj.Nmsc is 52 53 No_Continuation_String : aliased String := ""; 54 Continuation_String : aliased String := "\"; 55 -- Used in Check_Library for continuation error messages at the same 56 -- location. 57 58 type Name_Location is record 59 Name : File_Name_Type; 60 -- Key is duplicated, so that it is known when using functions Get_First 61 -- and Get_Next, as these functions only return an Element. 62 63 Location : Source_Ptr; 64 Source : Source_Id := No_Source; 65 Listed : Boolean := False; 66 Found : Boolean := False; 67 end record; 68 69 No_Name_Location : constant Name_Location := 70 (Name => No_File, 71 Location => No_Location, 72 Source => No_Source, 73 Listed => False, 74 Found => False); 75 76 package Source_Names_Htable is new GNAT.Dynamic_HTables.Simple_HTable 77 (Header_Num => Header_Num, 78 Element => Name_Location, 79 No_Element => No_Name_Location, 80 Key => File_Name_Type, 81 Hash => Hash, 82 Equal => "="); 83 -- File name information found in string list attribute (Source_Files or 84 -- Source_List_File). Used to check that all referenced files were indeed 85 -- found on the disk. 86 87 type Unit_Exception is record 88 Name : Name_Id; 89 -- Key is duplicated, so that it is known when using functions Get_First 90 -- and Get_Next, as these functions only return an Element. 91 92 Spec : File_Name_Type; 93 Impl : File_Name_Type; 94 end record; 95 96 No_Unit_Exception : constant Unit_Exception := (No_Name, No_File, No_File); 97 98 package Unit_Exceptions_Htable is new GNAT.Dynamic_HTables.Simple_HTable 99 (Header_Num => Header_Num, 100 Element => Unit_Exception, 101 No_Element => No_Unit_Exception, 102 Key => Name_Id, 103 Hash => Hash, 104 Equal => "="); 105 -- Record special naming schemes for Ada units (name of spec file and name 106 -- of implementation file). The elements in this list come from the naming 107 -- exceptions specified in the project files. 108 109 type File_Found is record 110 File : File_Name_Type := No_File; 111 Excl_File : File_Name_Type := No_File; 112 Excl_Line : Natural := 0; 113 Found : Boolean := False; 114 Location : Source_Ptr := No_Location; 115 end record; 116 117 No_File_Found : constant File_Found := 118 (No_File, No_File, 0, False, No_Location); 119 120 package Excluded_Sources_Htable is new GNAT.Dynamic_HTables.Simple_HTable 121 (Header_Num => Header_Num, 122 Element => File_Found, 123 No_Element => No_File_Found, 124 Key => File_Name_Type, 125 Hash => Hash, 126 Equal => "="); 127 -- A hash table to store the base names of excluded files, if any 128 129 package Object_File_Names_Htable is new GNAT.Dynamic_HTables.Simple_HTable 130 (Header_Num => Header_Num, 131 Element => Source_Id, 132 No_Element => No_Source, 133 Key => File_Name_Type, 134 Hash => Hash, 135 Equal => "="); 136 -- A hash table to store the object file names for a project, to check that 137 -- two different sources have different object file names. 138 139 type Project_Processing_Data is record 140 Project : Project_Id; 141 Source_Names : Source_Names_Htable.Instance; 142 Unit_Exceptions : Unit_Exceptions_Htable.Instance; 143 Excluded : Excluded_Sources_Htable.Instance; 144 145 Source_List_File_Location : Source_Ptr; 146 -- Location of the Source_List_File attribute, for error messages 147 end record; 148 -- This is similar to Tree_Processing_Data, but contains project-specific 149 -- information which is only useful while processing the project, and can 150 -- be discarded as soon as we have finished processing the project 151 152 type Tree_Processing_Data is record 153 Tree : Project_Tree_Ref; 154 Node_Tree : Prj.Tree.Project_Node_Tree_Ref; 155 Flags : Prj.Processing_Flags; 156 In_Aggregate_Lib : Boolean; 157 end record; 158 -- Temporary data which is needed while parsing a project. It does not need 159 -- to be kept in memory once a project has been fully loaded, but is 160 -- necessary while performing consistency checks (duplicate sources,...) 161 -- This data must be initialized before processing any project, and the 162 -- same data is used for processing all projects in the tree. 163 164 type Lib_Data is record 165 Name : Name_Id; 166 Proj : Project_Id; 167 Tree : Project_Tree_Ref; 168 end record; 169 170 package Lib_Data_Table is new GNAT.Table 171 (Table_Component_Type => Lib_Data, 172 Table_Index_Type => Natural, 173 Table_Low_Bound => 1, 174 Table_Initial => 10, 175 Table_Increment => 100); 176 -- A table to record library names in order to check that two library 177 -- projects do not have the same library names. 178 179 procedure Initialize 180 (Data : out Tree_Processing_Data; 181 Tree : Project_Tree_Ref; 182 Node_Tree : Prj.Tree.Project_Node_Tree_Ref; 183 Flags : Prj.Processing_Flags); 184 -- Initialize Data 185 186 procedure Free (Data : in out Tree_Processing_Data); 187 -- Free the memory occupied by Data 188 189 procedure Initialize 190 (Data : in out Project_Processing_Data; 191 Project : Project_Id); 192 procedure Free (Data : in out Project_Processing_Data); 193 -- Initialize or free memory for a project-specific data 194 195 procedure Find_Excluded_Sources 196 (Project : in out Project_Processing_Data; 197 Data : in out Tree_Processing_Data); 198 -- Find the list of files that should not be considered as source files 199 -- for this project. Sets the list in the Project.Excluded_Sources_Htable. 200 201 procedure Override_Kind (Source : Source_Id; Kind : Source_Kind); 202 -- Override the reference kind for a source file. This properly updates 203 -- the unit data if necessary. 204 205 procedure Load_Naming_Exceptions 206 (Project : in out Project_Processing_Data; 207 Data : in out Tree_Processing_Data); 208 -- All source files in Data.First_Source are considered as naming 209 -- exceptions, and copied into the Source_Names and Unit_Exceptions tables 210 -- as appropriate. 211 212 type Search_Type is (Search_Files, Search_Directories); 213 214 generic 215 with procedure Callback 216 (Path : Path_Information; 217 Pattern_Index : Natural); 218 procedure Expand_Subdirectory_Pattern 219 (Project : Project_Id; 220 Data : in out Tree_Processing_Data; 221 Patterns : String_List_Id; 222 Ignore : String_List_Id; 223 Search_For : Search_Type; 224 Resolve_Links : Boolean); 225 -- Search the subdirectories of Project's directory for files or 226 -- directories that match the globbing patterns found in Patterns (for 227 -- instance "**/*.adb"). Typically, Patterns will be the value of the 228 -- Source_Dirs or Excluded_Source_Dirs attributes. 229 -- 230 -- Every time such a file or directory is found, the callback is called. 231 -- Resolve_Links indicates whether we should resolve links while 232 -- normalizing names. 233 -- 234 -- In the callback, Pattern_Index is the index within Patterns where the 235 -- expanded pattern was found (1 for the first element of Patterns and 236 -- all its matching directories, then 2,...). 237 -- 238 -- We use a generic and not an access-to-subprogram because in some cases 239 -- this code is compiled with the restriction No_Implicit_Dynamic_Code. 240 -- An error message is raised if a pattern does not match any file. 241 242 procedure Add_Source 243 (Id : out Source_Id; 244 Data : in out Tree_Processing_Data; 245 Project : Project_Id; 246 Source_Dir_Rank : Natural; 247 Lang_Id : Language_Ptr; 248 Kind : Source_Kind; 249 File_Name : File_Name_Type; 250 Display_File : File_Name_Type; 251 Naming_Exception : Naming_Exception_Type := No; 252 Path : Path_Information := No_Path_Information; 253 Alternate_Languages : Language_List := null; 254 Unit : Name_Id := No_Name; 255 Index : Int := 0; 256 Locally_Removed : Boolean := False; 257 Location : Source_Ptr := No_Location); 258 -- Add a new source to the different lists: list of all sources in the 259 -- project tree, list of source of a project and list of sources of a 260 -- language. If Path is specified, the file is also added to 261 -- Source_Paths_HT. Location is used for error messages 262 263 function Canonical_Case_File_Name (Name : Name_Id) return File_Name_Type; 264 -- Same as Osint.Canonical_Case_File_Name but applies to Name_Id. 265 -- This alters Name_Buffer. 266 267 function Suffix_Matches 268 (Filename : String; 269 Suffix : File_Name_Type) return Boolean; 270 -- True if the file name ends with the given suffix. Always returns False 271 -- if Suffix is No_Name. 272 273 procedure Replace_Into_Name_Buffer 274 (Str : String; 275 Pattern : String; 276 Replacement : Character); 277 -- Copy Str into Name_Buffer, replacing Pattern with Replacement. Str is 278 -- converted to lower-case at the same time. 279 280 procedure Check_Abstract_Project 281 (Project : Project_Id; 282 Data : in out Tree_Processing_Data); 283 -- Check abstract projects attributes 284 285 procedure Check_Configuration 286 (Project : Project_Id; 287 Data : in out Tree_Processing_Data); 288 -- Check the configuration attributes for the project 289 290 procedure Check_If_Externally_Built 291 (Project : Project_Id; 292 Data : in out Tree_Processing_Data); 293 -- Check attribute Externally_Built of project Project in project tree 294 -- Data.Tree and modify its data Data if it has the value "true". 295 296 procedure Check_Interfaces 297 (Project : Project_Id; 298 Data : in out Tree_Processing_Data); 299 -- If a list of sources is specified in attribute Interfaces, set 300 -- In_Interfaces only for the sources specified in the list. 301 302 procedure Check_Library_Attributes 303 (Project : Project_Id; 304 Data : in out Tree_Processing_Data); 305 -- Check the library attributes of project Project in project tree 306 -- and modify its data Data accordingly. 307 308 procedure Check_Package_Naming 309 (Project : Project_Id; 310 Data : in out Tree_Processing_Data); 311 -- Check the naming scheme part of Data, and initialize the naming scheme 312 -- data in the config of the various languages. 313 314 procedure Check_Programming_Languages 315 (Project : Project_Id; 316 Data : in out Tree_Processing_Data); 317 -- Check attribute Languages for the project with data Data in project 318 -- tree Data.Tree and set the components of Data for all the programming 319 -- languages indicated in attribute Languages, if any. 320 321 procedure Check_Stand_Alone_Library 322 (Project : Project_Id; 323 Data : in out Tree_Processing_Data); 324 -- Check if project Project in project tree Data.Tree is a Stand-Alone 325 -- Library project, and modify its data Data accordingly if it is one. 326 327 procedure Check_Unit_Name (Name : String; Unit : out Name_Id); 328 -- Check that a name is a valid unit name 329 330 function Compute_Directory_Last (Dir : String) return Natural; 331 -- Return the index of the last significant character in Dir. This is used 332 -- to avoid duplicate '/' (slash) characters at the end of directory names. 333 334 procedure Search_Directories 335 (Project : in out Project_Processing_Data; 336 Data : in out Tree_Processing_Data; 337 For_All_Sources : Boolean); 338 -- Search the source directories to find the sources. If For_All_Sources is 339 -- True, check each regular file name against the naming schemes of the 340 -- various languages. Otherwise consider only the file names in hash table 341 -- Source_Names. If Allow_Duplicate_Basenames then files with identical 342 -- base names are permitted within a project for source-based languages 343 -- (never for unit based languages). 344 345 procedure Check_File 346 (Project : in out Project_Processing_Data; 347 Data : in out Tree_Processing_Data; 348 Source_Dir_Rank : Natural; 349 Path : Path_Name_Type; 350 Display_Path : Path_Name_Type; 351 File_Name : File_Name_Type; 352 Display_File_Name : File_Name_Type; 353 Locally_Removed : Boolean; 354 For_All_Sources : Boolean); 355 -- Check if file File_Name is a valid source of the project. This is used 356 -- in multi-language mode only. When the file matches one of the naming 357 -- schemes, it is added to various htables through Add_Source and to 358 -- Source_Paths_Htable. 359 -- 360 -- File_Name is the same as Display_File_Name, but has been normalized. 361 -- They do not include the directory information. 362 -- 363 -- Path and Display_Path on the other hand are the full path to the file. 364 -- Path must have been normalized (canonical casing and possibly links 365 -- resolved). 366 -- 367 -- Source_Directory is the directory in which the file was found. It is 368 -- neither normalized nor has had links resolved, and must not end with a 369 -- a directory separator, to avoid duplicates later on. 370 -- 371 -- If For_All_Sources is True, then all possible file names are analyzed 372 -- otherwise only those currently set in the Source_Names hash table. 373 374 procedure Check_File_Naming_Schemes 375 (Project : Project_Processing_Data; 376 File_Name : File_Name_Type; 377 Alternate_Languages : out Language_List; 378 Language : out Language_Ptr; 379 Display_Language_Name : out Name_Id; 380 Unit : out Name_Id; 381 Lang_Kind : out Language_Kind; 382 Kind : out Source_Kind); 383 -- Check if the file name File_Name conforms to one of the naming schemes 384 -- of the project. If the file does not match one of the naming schemes, 385 -- set Language to No_Language_Index. Filename is the name of the file 386 -- being investigated. It has been normalized (case-folded). File_Name is 387 -- the same value. 388 389 procedure Get_Directories 390 (Project : Project_Id; 391 Data : in out Tree_Processing_Data); 392 -- Get the object directory, the exec directory and the source directories 393 -- of a project. 394 395 procedure Get_Mains 396 (Project : Project_Id; 397 Data : in out Tree_Processing_Data); 398 -- Get the mains of a project from attribute Main, if it exists, and put 399 -- them in the project data. 400 401 procedure Get_Sources_From_File 402 (Path : String; 403 Location : Source_Ptr; 404 Project : in out Project_Processing_Data; 405 Data : in out Tree_Processing_Data); 406 -- Get the list of sources from a text file and put them in hash table 407 -- Source_Names. 408 409 procedure Find_Sources 410 (Project : in out Project_Processing_Data; 411 Data : in out Tree_Processing_Data); 412 -- Process the Source_Files and Source_List_File attributes, and store the 413 -- list of source files into the Source_Names htable. When these attributes 414 -- are not defined, find all files matching the naming schemes in the 415 -- source directories. If Allow_Duplicate_Basenames, then files with the 416 -- same base names are authorized within a project for source-based 417 -- languages (never for unit based languages) 418 419 procedure Compute_Unit_Name 420 (File_Name : File_Name_Type; 421 Naming : Lang_Naming_Data; 422 Kind : out Source_Kind; 423 Unit : out Name_Id; 424 Project : Project_Processing_Data); 425 -- Check whether the file matches the naming scheme. If it does, 426 -- compute its unit name. If Unit is set to No_Name on exit, none of the 427 -- other out parameters are relevant. 428 429 procedure Check_Illegal_Suffix 430 (Project : Project_Id; 431 Suffix : File_Name_Type; 432 Dot_Replacement : File_Name_Type; 433 Attribute_Name : String; 434 Location : Source_Ptr; 435 Data : in out Tree_Processing_Data); 436 -- Display an error message if the given suffix is illegal for some reason. 437 -- The name of the attribute we are testing is specified in Attribute_Name, 438 -- which is used in the error message. Location is the location where the 439 -- suffix is defined. 440 441 procedure Locate_Directory 442 (Project : Project_Id; 443 Name : File_Name_Type; 444 Path : out Path_Information; 445 Dir_Exists : out Boolean; 446 Data : in out Tree_Processing_Data; 447 Create : String := ""; 448 Location : Source_Ptr := No_Location; 449 Must_Exist : Boolean := True; 450 Externally_Built : Boolean := False); 451 -- Locate a directory. Name is the directory name. Relative paths are 452 -- resolved relative to the project's directory. If the directory does not 453 -- exist and Setup_Projects is True and Create is a non null string, an 454 -- attempt is made to create the directory. If the directory does not 455 -- exist, it is either created if Setup_Projects is False (and then 456 -- returned), or simply returned without checking for its existence (if 457 -- Must_Exist is False) or No_Path_Information is returned. In all cases, 458 -- Dir_Exists indicates whether the directory now exists. Create is also 459 -- used for debugging traces to show which path we are computing. 460 461 procedure Look_For_Sources 462 (Project : in out Project_Processing_Data; 463 Data : in out Tree_Processing_Data); 464 -- Find all the sources of project Project in project tree Data.Tree and 465 -- update its Data accordingly. This assumes that the special naming 466 -- exceptions have already been processed. 467 468 function Path_Name_Of 469 (File_Name : File_Name_Type; 470 Directory : Path_Name_Type) return String; 471 -- Returns the path name of a (non project) file. Returns an empty string 472 -- if file cannot be found. 473 474 procedure Remove_Source 475 (Tree : Project_Tree_Ref; 476 Id : Source_Id; 477 Replaced_By : Source_Id); 478 -- Remove a file from the list of sources of a project. This might be 479 -- because the file is replaced by another one in an extending project, 480 -- or because a file was added as a naming exception but was not found 481 -- in the end. 482 483 procedure Report_No_Sources 484 (Project : Project_Id; 485 Lang_Name : String; 486 Data : Tree_Processing_Data; 487 Location : Source_Ptr; 488 Continuation : Boolean := False); 489 -- Report an error or a warning depending on the value of When_No_Sources 490 -- when there are no sources for language Lang_Name. 491 492 procedure Show_Source_Dirs 493 (Project : Project_Id; 494 Shared : Shared_Project_Tree_Data_Access); 495 -- List all the source directories of a project 496 497 procedure Write_Attr (Name, Value : String); 498 -- Debug print a value for a specific property. Does nothing when not in 499 -- debug mode 500 501 procedure Error_Or_Warning 502 (Flags : Processing_Flags; 503 Kind : Error_Warning; 504 Msg : String; 505 Location : Source_Ptr; 506 Project : Project_Id); 507 -- Emits either an error or warning message (or nothing), depending on Kind 508 509 function No_Space_Img (N : Natural) return String; 510 -- Image of a Natural without the initial space 511 512 ---------------------- 513 -- Error_Or_Warning -- 514 ---------------------- 515 516 procedure Error_Or_Warning 517 (Flags : Processing_Flags; 518 Kind : Error_Warning; 519 Msg : String; 520 Location : Source_Ptr; 521 Project : Project_Id) is 522 begin 523 case Kind is 524 when Error => Error_Msg (Flags, Msg, Location, Project); 525 when Warning => Error_Msg (Flags, "?" & Msg, Location, Project); 526 when Silent => null; 527 end case; 528 end Error_Or_Warning; 529 530 ------------------------------ 531 -- Replace_Into_Name_Buffer -- 532 ------------------------------ 533 534 procedure Replace_Into_Name_Buffer 535 (Str : String; 536 Pattern : String; 537 Replacement : Character) 538 is 539 Max : constant Integer := Str'Last - Pattern'Length + 1; 540 J : Positive; 541 542 begin 543 Name_Len := 0; 544 545 J := Str'First; 546 while J <= Str'Last loop 547 Name_Len := Name_Len + 1; 548 549 if J <= Max and then Str (J .. J + Pattern'Length - 1) = Pattern then 550 Name_Buffer (Name_Len) := Replacement; 551 J := J + Pattern'Length; 552 else 553 Name_Buffer (Name_Len) := GNAT.Case_Util.To_Lower (Str (J)); 554 J := J + 1; 555 end if; 556 end loop; 557 end Replace_Into_Name_Buffer; 558 559 -------------------- 560 -- Suffix_Matches -- 561 -------------------- 562 563 function Suffix_Matches 564 (Filename : String; 565 Suffix : File_Name_Type) return Boolean 566 is 567 Min_Prefix_Length : Natural := 0; 568 569 begin 570 if Suffix = No_File or else Suffix = Empty_File then 571 return False; 572 end if; 573 574 declare 575 Suf : String := Get_Name_String (Suffix); 576 577 begin 578 -- On non case-sensitive systems, use proper suffix casing 579 580 Canonical_Case_File_Name (Suf); 581 582 -- The file name must end with the suffix (which is not an extension) 583 -- For instance a suffix "configure.ac" must match a file with the 584 -- same name. To avoid dummy cases, though, a suffix starting with 585 -- '.' requires a file that is at least one character longer ('.cpp' 586 -- should not match a file with the same name). 587 588 if Suf (Suf'First) = '.' then 589 Min_Prefix_Length := 1; 590 end if; 591 592 return Filename'Length >= Suf'Length + Min_Prefix_Length 593 and then 594 Filename (Filename'Last - Suf'Length + 1 .. Filename'Last) = Suf; 595 end; 596 end Suffix_Matches; 597 598 ---------------- 599 -- Write_Attr -- 600 ---------------- 601 602 procedure Write_Attr (Name, Value : String) is 603 begin 604 if Current_Verbosity = High then 605 Debug_Output (Name & " = """ & Value & '"'); 606 end if; 607 end Write_Attr; 608 609 ---------------- 610 -- Add_Source -- 611 ---------------- 612 613 procedure Add_Source 614 (Id : out Source_Id; 615 Data : in out Tree_Processing_Data; 616 Project : Project_Id; 617 Source_Dir_Rank : Natural; 618 Lang_Id : Language_Ptr; 619 Kind : Source_Kind; 620 File_Name : File_Name_Type; 621 Display_File : File_Name_Type; 622 Naming_Exception : Naming_Exception_Type := No; 623 Path : Path_Information := No_Path_Information; 624 Alternate_Languages : Language_List := null; 625 Unit : Name_Id := No_Name; 626 Index : Int := 0; 627 Locally_Removed : Boolean := False; 628 Location : Source_Ptr := No_Location) 629 is 630 Config : constant Language_Config := Lang_Id.Config; 631 UData : Unit_Index; 632 Add_Src : Boolean; 633 Source : Source_Id; 634 Prev_Unit : Unit_Index := No_Unit_Index; 635 Source_To_Replace : Source_Id := No_Source; 636 637 begin 638 -- Check if the same file name or unit is used in the prj tree 639 640 Add_Src := True; 641 642 if Unit /= No_Name then 643 Prev_Unit := Units_Htable.Get (Data.Tree.Units_HT, Unit); 644 end if; 645 646 if Prev_Unit /= No_Unit_Index 647 and then (Kind = Impl or else Kind = Spec) 648 and then Prev_Unit.File_Names (Kind) /= null 649 then 650 -- Suspicious, we need to check later whether this is authorized 651 652 Add_Src := False; 653 Source := Prev_Unit.File_Names (Kind); 654 655 else 656 Source := Source_Files_Htable.Get 657 (Data.Tree.Source_Files_HT, File_Name); 658 659 if Source /= No_Source and then Source.Index = Index then 660 Add_Src := False; 661 end if; 662 end if; 663 664 -- Always add the source if it is locally removed, to avoid incorrect 665 -- duplicate checks. 666 667 if Locally_Removed then 668 Add_Src := True; 669 670 -- A locally removed source may first replace a source in a project 671 -- being extended. 672 673 if Source /= No_Source 674 and then Is_Extending (Project, Source.Project) 675 and then Naming_Exception /= Inherited 676 then 677 Source_To_Replace := Source; 678 end if; 679 680 else 681 -- Duplication of file/unit in same project is allowed if order of 682 -- source directories is known, or if there is no compiler for the 683 -- language. 684 685 if Add_Src = False then 686 Add_Src := True; 687 688 if Project = Source.Project then 689 if Prev_Unit = No_Unit_Index then 690 if Data.Flags.Allow_Duplicate_Basenames then 691 Add_Src := True; 692 693 elsif Lang_Id.Config.Compiler_Driver = Empty_File then 694 Add_Src := True; 695 696 elsif Source_Dir_Rank /= Source.Source_Dir_Rank then 697 Add_Src := False; 698 699 else 700 Error_Msg_File_1 := File_Name; 701 Error_Msg 702 (Data.Flags, "duplicate source file name {", 703 Location, Project); 704 Add_Src := False; 705 end if; 706 707 else 708 if Source_Dir_Rank /= Source.Source_Dir_Rank then 709 Add_Src := False; 710 711 -- We might be seeing the same file through a different 712 -- path (for instance because of symbolic links). 713 714 elsif Source.Path.Name /= Path.Name then 715 if not Source.Duplicate_Unit then 716 Error_Msg_Name_1 := Unit; 717 Error_Msg 718 (Data.Flags, 719 "\duplicate unit %%", 720 Location, 721 Project); 722 Source.Duplicate_Unit := True; 723 end if; 724 725 Add_Src := False; 726 end if; 727 end if; 728 729 -- Do not allow the same unit name in different projects, 730 -- except if one is extending the other. 731 732 -- For a file based language, the same file name replaces a 733 -- file in a project being extended, but it is allowed to have 734 -- the same file name in unrelated projects. 735 736 elsif Is_Extending (Project, Source.Project) then 737 if not Locally_Removed and then Naming_Exception /= Inherited 738 then 739 Source_To_Replace := Source; 740 end if; 741 742 elsif Prev_Unit /= No_Unit_Index 743 and then Prev_Unit.File_Names (Kind) /= null 744 and then not Source.Locally_Removed 745 and then Source.Replaced_By = No_Source 746 and then not Data.In_Aggregate_Lib 747 then 748 -- Path is set if this is a source we found on the disk, in 749 -- which case we can provide more explicit error message. Path 750 -- is unset when the source is added from one of the naming 751 -- exceptions in the project. 752 753 if Path /= No_Path_Information then 754 Error_Msg_Name_1 := Unit; 755 Error_Msg 756 (Data.Flags, 757 "unit %% cannot belong to several projects", 758 Location, Project); 759 760 Error_Msg_Name_1 := Project.Name; 761 Error_Msg_Name_2 := Name_Id (Path.Display_Name); 762 Error_Msg 763 (Data.Flags, "\ project %%, %%", Location, Project); 764 765 Error_Msg_Name_1 := Source.Project.Name; 766 Error_Msg_Name_2 := Name_Id (Source.Path.Display_Name); 767 Error_Msg 768 (Data.Flags, "\ project %%, %%", Location, Project); 769 770 else 771 Error_Msg_Name_1 := Unit; 772 Error_Msg_Name_2 := Source.Project.Name; 773 Error_Msg 774 (Data.Flags, "unit %% already belongs to project %%", 775 Location, Project); 776 end if; 777 778 Add_Src := False; 779 780 elsif not Source.Locally_Removed 781 and then Source.Replaced_By /= No_Source 782 and then not Data.Flags.Allow_Duplicate_Basenames 783 and then Lang_Id.Config.Kind = Unit_Based 784 and then Source.Language.Config.Kind = Unit_Based 785 and then not Data.In_Aggregate_Lib 786 then 787 Error_Msg_File_1 := File_Name; 788 Error_Msg_File_2 := File_Name_Type (Source.Project.Name); 789 Error_Msg 790 (Data.Flags, 791 "{ is already a source of project {", Location, Project); 792 793 -- Add the file anyway, to avoid further warnings like 794 -- "language unknown". 795 796 Add_Src := True; 797 end if; 798 end if; 799 end if; 800 801 if not Add_Src then 802 return; 803 end if; 804 805 -- Add the new file 806 807 Id := new Source_Data; 808 809 if Current_Verbosity = High then 810 Debug_Indent; 811 Write_Str ("adding source File: "); 812 Write_Str (Get_Name_String (Display_File)); 813 814 if Index /= 0 then 815 Write_Str (" at" & Index'Img); 816 end if; 817 818 if Lang_Id.Config.Kind = Unit_Based then 819 Write_Str (" Unit: "); 820 821 -- ??? in gprclean, it seems we sometimes pass an empty Unit name 822 -- (see test extended_projects). 823 824 if Unit /= No_Name then 825 Write_Str (Get_Name_String (Unit)); 826 end if; 827 828 Write_Str (" Kind: "); 829 Write_Str (Source_Kind'Image (Kind)); 830 end if; 831 832 Write_Eol; 833 end if; 834 835 Id.Project := Project; 836 Id.Location := Location; 837 Id.Source_Dir_Rank := Source_Dir_Rank; 838 Id.Language := Lang_Id; 839 Id.Kind := Kind; 840 Id.Alternate_Languages := Alternate_Languages; 841 Id.Locally_Removed := Locally_Removed; 842 Id.Index := Index; 843 Id.File := File_Name; 844 Id.Display_File := Display_File; 845 Id.Dep_Name := Dependency_Name 846 (File_Name, Lang_Id.Config.Dependency_Kind); 847 Id.Naming_Exception := Naming_Exception; 848 Id.Object := Object_Name 849 (File_Name, Config.Object_File_Suffix); 850 Id.Switches := Switches_Name (File_Name); 851 852 -- Add the source id to the Unit_Sources_HT hash table, if the unit name 853 -- is not null. 854 855 if Unit /= No_Name then 856 857 -- Note: we might be creating a dummy unit here, when we in fact have 858 -- a separate. For instance, file file-bar.adb will initially be 859 -- assumed to be the IMPL of unit "file.bar". Only later on (in 860 -- Check_Object_Files) will we parse those units that only have an 861 -- impl and no spec to make sure whether we have a Separate in fact 862 -- (that significantly reduces the number of times we need to parse 863 -- the files, since we are then only interested in those with no 864 -- spec). We still need those dummy units in the table, since that's 865 -- the name we find in the ALI file 866 867 UData := Units_Htable.Get (Data.Tree.Units_HT, Unit); 868 869 if UData = No_Unit_Index then 870 UData := new Unit_Data; 871 UData.Name := Unit; 872 873 if Naming_Exception /= Inherited then 874 Units_Htable.Set (Data.Tree.Units_HT, Unit, UData); 875 end if; 876 end if; 877 878 Id.Unit := UData; 879 880 -- Note that this updates Unit information as well 881 882 if Naming_Exception /= Inherited and then not Locally_Removed then 883 Override_Kind (Id, Kind); 884 end if; 885 end if; 886 887 if Path /= No_Path_Information then 888 Id.Path := Path; 889 Source_Paths_Htable.Set (Data.Tree.Source_Paths_HT, Path.Name, Id); 890 end if; 891 892 Id.Next_With_File_Name := 893 Source_Files_Htable.Get (Data.Tree.Source_Files_HT, File_Name); 894 Source_Files_Htable.Set (Data.Tree.Source_Files_HT, File_Name, Id); 895 896 if Index /= 0 then 897 Project.Has_Multi_Unit_Sources := True; 898 end if; 899 900 -- Add the source to the language list 901 902 Id.Next_In_Lang := Lang_Id.First_Source; 903 Lang_Id.First_Source := Id; 904 905 if Source_To_Replace /= No_Source then 906 Remove_Source (Data.Tree, Source_To_Replace, Id); 907 end if; 908 909 if Data.Tree.Replaced_Source_Number > 0 910 and then 911 Replaced_Source_HTable.Get 912 (Data.Tree.Replaced_Sources, Id.File) /= No_File 913 then 914 Replaced_Source_HTable.Remove (Data.Tree.Replaced_Sources, Id.File); 915 Data.Tree.Replaced_Source_Number := 916 Data.Tree.Replaced_Source_Number - 1; 917 end if; 918 end Add_Source; 919 920 ------------------------------ 921 -- Canonical_Case_File_Name -- 922 ------------------------------ 923 924 function Canonical_Case_File_Name (Name : Name_Id) return File_Name_Type is 925 begin 926 if Osint.File_Names_Case_Sensitive then 927 return File_Name_Type (Name); 928 else 929 Get_Name_String (Name); 930 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); 931 return Name_Find; 932 end if; 933 end Canonical_Case_File_Name; 934 935 --------------------------------- 936 -- Process_Aggregated_Projects -- 937 --------------------------------- 938 939 procedure Process_Aggregated_Projects 940 (Tree : Project_Tree_Ref; 941 Project : Project_Id; 942 Node_Tree : Prj.Tree.Project_Node_Tree_Ref; 943 Flags : Processing_Flags) 944 is 945 Data : Tree_Processing_Data := 946 (Tree => Tree, 947 Node_Tree => Node_Tree, 948 Flags => Flags, 949 In_Aggregate_Lib => False); 950 951 Project_Files : constant Prj.Variable_Value := 952 Prj.Util.Value_Of 953 (Snames.Name_Project_Files, 954 Project.Decl.Attributes, 955 Tree.Shared); 956 957 Project_Path_For_Aggregate : Prj.Env.Project_Search_Path; 958 959 procedure Found_Project_File (Path : Path_Information; Rank : Natural); 960 -- Called for each project file aggregated by Project 961 962 procedure Expand_Project_Files is 963 new Expand_Subdirectory_Pattern (Callback => Found_Project_File); 964 -- Search for all project files referenced by the patterns given in 965 -- parameter. Calls Found_Project_File for each of them. 966 967 ------------------------ 968 -- Found_Project_File -- 969 ------------------------ 970 971 procedure Found_Project_File (Path : Path_Information; Rank : Natural) is 972 pragma Unreferenced (Rank); 973 974 begin 975 if Path.Name /= Project.Path.Name then 976 Debug_Output ("aggregates: ", Name_Id (Path.Display_Name)); 977 978 -- For usual "with" statement, this phase will have been done when 979 -- parsing the project itself. However, for aggregate projects, we 980 -- can only do this when processing the aggregate project, since 981 -- the exact list of project files or project directories can 982 -- depend on scenario variables. 983 -- 984 -- We only load the projects explicitly here, but do not process 985 -- them. For the processing, Prj.Proc will take care of processing 986 -- them, within the same call to Recursive_Process (thus avoiding 987 -- the processing of a given project multiple times). 988 -- 989 -- ??? We might already have loaded the project 990 991 Add_Aggregated_Project (Project, Path => Path.Name); 992 993 else 994 Debug_Output ("pattern returned the aggregate itself, ignored"); 995 end if; 996 end Found_Project_File; 997 998 -- Start of processing for Check_Aggregate_Project 999 1000 begin 1001 pragma Assert (Project.Qualifier in Aggregate_Project); 1002 1003 if Project_Files.Default then 1004 Error_Msg_Name_1 := Snames.Name_Project_Files; 1005 Error_Msg 1006 (Flags, 1007 "Attribute %% must be specified in aggregate project", 1008 Project.Location, Project); 1009 return; 1010 end if; 1011 1012 -- The aggregated projects are only searched relative to the directory 1013 -- of the aggregate project, not in the default project path. 1014 1015 Initialize_Empty (Project_Path_For_Aggregate); 1016 1017 Free (Project.Aggregated_Projects); 1018 1019 -- Look for aggregated projects. For similarity with source files and 1020 -- dirs, the aggregated project files are not searched for on the 1021 -- project path, and are only found through the path specified in 1022 -- the Project_Files attribute. 1023 1024 Expand_Project_Files 1025 (Project => Project, 1026 Data => Data, 1027 Patterns => Project_Files.Values, 1028 Ignore => Nil_String, 1029 Search_For => Search_Files, 1030 Resolve_Links => Opt.Follow_Links_For_Files); 1031 1032 Free (Project_Path_For_Aggregate); 1033 end Process_Aggregated_Projects; 1034 1035 ---------------------------- 1036 -- Check_Abstract_Project -- 1037 ---------------------------- 1038 1039 procedure Check_Abstract_Project 1040 (Project : Project_Id; 1041 Data : in out Tree_Processing_Data) 1042 is 1043 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; 1044 1045 Source_Dirs : constant Variable_Value := 1046 Util.Value_Of 1047 (Name_Source_Dirs, 1048 Project.Decl.Attributes, Shared); 1049 Source_Files : constant Variable_Value := 1050 Util.Value_Of 1051 (Name_Source_Files, 1052 Project.Decl.Attributes, Shared); 1053 Source_List_File : constant Variable_Value := 1054 Util.Value_Of 1055 (Name_Source_List_File, 1056 Project.Decl.Attributes, Shared); 1057 Languages : constant Variable_Value := 1058 Util.Value_Of 1059 (Name_Languages, 1060 Project.Decl.Attributes, Shared); 1061 1062 begin 1063 if Project.Source_Dirs /= Nil_String then 1064 if Source_Dirs.Values = Nil_String 1065 and then Source_Files.Values = Nil_String 1066 and then Languages.Values = Nil_String 1067 and then Source_List_File.Default 1068 then 1069 Project.Source_Dirs := Nil_String; 1070 1071 else 1072 Error_Msg 1073 (Data.Flags, 1074 "at least one of Source_Files, Source_Dirs or Languages " 1075 & "must be declared empty for an abstract project", 1076 Project.Location, Project); 1077 end if; 1078 end if; 1079 end Check_Abstract_Project; 1080 1081 ------------------------- 1082 -- Check_Configuration -- 1083 ------------------------- 1084 1085 procedure Check_Configuration 1086 (Project : Project_Id; 1087 Data : in out Tree_Processing_Data) 1088 is 1089 Shared : constant Shared_Project_Tree_Data_Access := 1090 Data.Tree.Shared; 1091 1092 Dot_Replacement : File_Name_Type := No_File; 1093 Casing : Casing_Type := All_Lower_Case; 1094 Separate_Suffix : File_Name_Type := No_File; 1095 1096 Lang_Index : Language_Ptr := No_Language_Index; 1097 -- The index of the language data being checked 1098 1099 Prev_Index : Language_Ptr := No_Language_Index; 1100 -- The index of the previous language 1101 1102 procedure Process_Project_Level_Simple_Attributes; 1103 -- Process the simple attributes at the project level 1104 1105 procedure Process_Project_Level_Array_Attributes; 1106 -- Process the associate array attributes at the project level 1107 1108 procedure Process_Packages; 1109 -- Read the packages of the project 1110 1111 ---------------------- 1112 -- Process_Packages -- 1113 ---------------------- 1114 1115 procedure Process_Packages is 1116 Packages : Package_Id; 1117 Element : Package_Element; 1118 1119 procedure Process_Binder (Arrays : Array_Id); 1120 -- Process the associated array attributes of package Binder 1121 1122 procedure Process_Builder (Attributes : Variable_Id); 1123 -- Process the simple attributes of package Builder 1124 1125 procedure Process_Clean (Attributes : Variable_Id); 1126 -- Process the simple attributes of package Clean 1127 1128 procedure Process_Clean (Arrays : Array_Id); 1129 -- Process the associated array attributes of package Clean 1130 1131 procedure Process_Compiler (Arrays : Array_Id); 1132 -- Process the associated array attributes of package Compiler 1133 1134 procedure Process_Naming (Attributes : Variable_Id); 1135 -- Process the simple attributes of package Naming 1136 1137 procedure Process_Naming (Arrays : Array_Id); 1138 -- Process the associated array attributes of package Naming 1139 1140 procedure Process_Linker (Attributes : Variable_Id); 1141 -- Process the simple attributes of package Linker of a 1142 -- configuration project. 1143 1144 -------------------- 1145 -- Process_Binder -- 1146 -------------------- 1147 1148 procedure Process_Binder (Arrays : Array_Id) is 1149 Current_Array_Id : Array_Id; 1150 Current_Array : Array_Data; 1151 Element_Id : Array_Element_Id; 1152 Element : Array_Element; 1153 1154 begin 1155 -- Process the associative array attribute of package Binder 1156 1157 Current_Array_Id := Arrays; 1158 while Current_Array_Id /= No_Array loop 1159 Current_Array := Shared.Arrays.Table (Current_Array_Id); 1160 1161 Element_Id := Current_Array.Value; 1162 while Element_Id /= No_Array_Element loop 1163 Element := Shared.Array_Elements.Table (Element_Id); 1164 1165 if Element.Index /= All_Other_Names then 1166 1167 -- Get the name of the language 1168 1169 Lang_Index := 1170 Get_Language_From_Name 1171 (Project, Get_Name_String (Element.Index)); 1172 1173 if Lang_Index /= No_Language_Index then 1174 case Current_Array.Name is 1175 when Name_Driver => 1176 1177 -- Attribute Driver (<language>) 1178 1179 Lang_Index.Config.Binder_Driver := 1180 File_Name_Type (Element.Value.Value); 1181 1182 when Name_Required_Switches => 1183 Put 1184 (Into_List => 1185 Lang_Index.Config.Binder_Required_Switches, 1186 From_List => Element.Value.Values, 1187 In_Tree => Data.Tree); 1188 1189 when Name_Prefix => 1190 1191 -- Attribute Prefix (<language>) 1192 1193 Lang_Index.Config.Binder_Prefix := 1194 Element.Value.Value; 1195 1196 when Name_Objects_Path => 1197 1198 -- Attribute Objects_Path (<language>) 1199 1200 Lang_Index.Config.Objects_Path := 1201 Element.Value.Value; 1202 1203 when Name_Objects_Path_File => 1204 1205 -- Attribute Objects_Path (<language>) 1206 1207 Lang_Index.Config.Objects_Path_File := 1208 Element.Value.Value; 1209 1210 when others => 1211 null; 1212 end case; 1213 end if; 1214 end if; 1215 1216 Element_Id := Element.Next; 1217 end loop; 1218 1219 Current_Array_Id := Current_Array.Next; 1220 end loop; 1221 end Process_Binder; 1222 1223 --------------------- 1224 -- Process_Builder -- 1225 --------------------- 1226 1227 procedure Process_Builder (Attributes : Variable_Id) is 1228 Attribute_Id : Variable_Id; 1229 Attribute : Variable; 1230 1231 begin 1232 -- Process non associated array attribute from package Builder 1233 1234 Attribute_Id := Attributes; 1235 while Attribute_Id /= No_Variable loop 1236 Attribute := Shared.Variable_Elements.Table (Attribute_Id); 1237 1238 if not Attribute.Value.Default then 1239 if Attribute.Name = Name_Executable_Suffix then 1240 1241 -- Attribute Executable_Suffix: the suffix of the 1242 -- executables. 1243 1244 Project.Config.Executable_Suffix := 1245 Attribute.Value.Value; 1246 end if; 1247 end if; 1248 1249 Attribute_Id := Attribute.Next; 1250 end loop; 1251 end Process_Builder; 1252 1253 ------------------- 1254 -- Process_Clean -- 1255 ------------------- 1256 1257 procedure Process_Clean (Attributes : Variable_Id) is 1258 Attribute_Id : Variable_Id; 1259 Attribute : Variable; 1260 List : String_List_Id; 1261 1262 begin 1263 -- Process non associated array attributes from package Clean 1264 1265 Attribute_Id := Attributes; 1266 while Attribute_Id /= No_Variable loop 1267 Attribute := Shared.Variable_Elements.Table (Attribute_Id); 1268 1269 if not Attribute.Value.Default then 1270 if Attribute.Name = Name_Artifacts_In_Exec_Dir then 1271 1272 -- Attribute Artifacts_In_Exec_Dir: the list of file 1273 -- names to be cleaned in the exec dir of the main 1274 -- project. 1275 1276 List := Attribute.Value.Values; 1277 1278 if List /= Nil_String then 1279 Put (Into_List => 1280 Project.Config.Artifacts_In_Exec_Dir, 1281 From_List => List, 1282 In_Tree => Data.Tree); 1283 end if; 1284 1285 elsif Attribute.Name = Name_Artifacts_In_Object_Dir then 1286 1287 -- Attribute Artifacts_In_Exec_Dir: the list of file 1288 -- names to be cleaned in the object dir of every 1289 -- project. 1290 1291 List := Attribute.Value.Values; 1292 1293 if List /= Nil_String then 1294 Put (Into_List => 1295 Project.Config.Artifacts_In_Object_Dir, 1296 From_List => List, 1297 In_Tree => Data.Tree); 1298 end if; 1299 end if; 1300 end if; 1301 1302 Attribute_Id := Attribute.Next; 1303 end loop; 1304 end Process_Clean; 1305 1306 procedure Process_Clean (Arrays : Array_Id) is 1307 Current_Array_Id : Array_Id; 1308 Current_Array : Array_Data; 1309 Element_Id : Array_Element_Id; 1310 Element : Array_Element; 1311 List : String_List_Id; 1312 1313 begin 1314 -- Process the associated array attributes of package Clean 1315 1316 Current_Array_Id := Arrays; 1317 while Current_Array_Id /= No_Array loop 1318 Current_Array := Shared.Arrays.Table (Current_Array_Id); 1319 1320 Element_Id := Current_Array.Value; 1321 while Element_Id /= No_Array_Element loop 1322 Element := Shared.Array_Elements.Table (Element_Id); 1323 1324 -- Get the name of the language 1325 1326 Lang_Index := 1327 Get_Language_From_Name 1328 (Project, Get_Name_String (Element.Index)); 1329 1330 if Lang_Index /= No_Language_Index then 1331 case Current_Array.Name is 1332 1333 -- Attribute Object_Artifact_Extensions (<language>) 1334 1335 when Name_Object_Artifact_Extensions => 1336 List := Element.Value.Values; 1337 1338 if List /= Nil_String then 1339 Put (Into_List => 1340 Lang_Index.Config.Clean_Object_Artifacts, 1341 From_List => List, 1342 In_Tree => Data.Tree); 1343 end if; 1344 1345 -- Attribute Source_Artifact_Extensions (<language>) 1346 1347 when Name_Source_Artifact_Extensions => 1348 List := Element.Value.Values; 1349 1350 if List /= Nil_String then 1351 Put (Into_List => 1352 Lang_Index.Config.Clean_Source_Artifacts, 1353 From_List => List, 1354 In_Tree => Data.Tree); 1355 end if; 1356 1357 when others => 1358 null; 1359 end case; 1360 end if; 1361 1362 Element_Id := Element.Next; 1363 end loop; 1364 1365 Current_Array_Id := Current_Array.Next; 1366 end loop; 1367 end Process_Clean; 1368 1369 ---------------------- 1370 -- Process_Compiler -- 1371 ---------------------- 1372 1373 procedure Process_Compiler (Arrays : Array_Id) is 1374 Current_Array_Id : Array_Id; 1375 Current_Array : Array_Data; 1376 Element_Id : Array_Element_Id; 1377 Element : Array_Element; 1378 List : String_List_Id; 1379 1380 begin 1381 -- Process the associative array attribute of package Compiler 1382 1383 Current_Array_Id := Arrays; 1384 while Current_Array_Id /= No_Array loop 1385 Current_Array := Shared.Arrays.Table (Current_Array_Id); 1386 1387 Element_Id := Current_Array.Value; 1388 while Element_Id /= No_Array_Element loop 1389 Element := Shared.Array_Elements.Table (Element_Id); 1390 1391 if Element.Index /= All_Other_Names then 1392 1393 -- Get the name of the language 1394 1395 Lang_Index := Get_Language_From_Name 1396 (Project, Get_Name_String (Element.Index)); 1397 1398 if Lang_Index /= No_Language_Index then 1399 case Current_Array.Name is 1400 1401 -- Attribute Dependency_Kind (<language>) 1402 1403 when Name_Dependency_Kind => 1404 Get_Name_String (Element.Value.Value); 1405 1406 begin 1407 Lang_Index.Config.Dependency_Kind := 1408 Dependency_File_Kind'Value 1409 (Name_Buffer (1 .. Name_Len)); 1410 1411 exception 1412 when Constraint_Error => 1413 Error_Msg 1414 (Data.Flags, 1415 "illegal value for Dependency_Kind", 1416 Element.Value.Location, 1417 Project); 1418 end; 1419 1420 -- Attribute Dependency_Switches (<language>) 1421 1422 when Name_Dependency_Switches => 1423 if Lang_Index.Config.Dependency_Kind = None then 1424 Lang_Index.Config.Dependency_Kind := Makefile; 1425 end if; 1426 1427 List := Element.Value.Values; 1428 1429 if List /= Nil_String then 1430 Put (Into_List => 1431 Lang_Index.Config.Dependency_Option, 1432 From_List => List, 1433 In_Tree => Data.Tree); 1434 end if; 1435 1436 -- Attribute Dependency_Driver (<language>) 1437 1438 when Name_Dependency_Driver => 1439 if Lang_Index.Config.Dependency_Kind = None then 1440 Lang_Index.Config.Dependency_Kind := Makefile; 1441 end if; 1442 1443 List := Element.Value.Values; 1444 1445 if List /= Nil_String then 1446 Put (Into_List => 1447 Lang_Index.Config.Compute_Dependency, 1448 From_List => List, 1449 In_Tree => Data.Tree); 1450 end if; 1451 1452 -- Attribute Language_Kind (<language>) 1453 1454 when Name_Language_Kind => 1455 Get_Name_String (Element.Value.Value); 1456 1457 begin 1458 Lang_Index.Config.Kind := 1459 Language_Kind'Value 1460 (Name_Buffer (1 .. Name_Len)); 1461 1462 exception 1463 when Constraint_Error => 1464 Error_Msg 1465 (Data.Flags, 1466 "illegal value for Language_Kind", 1467 Element.Value.Location, 1468 Project); 1469 end; 1470 1471 -- Attribute Include_Switches (<language>) 1472 1473 when Name_Include_Switches => 1474 List := Element.Value.Values; 1475 1476 if List = Nil_String then 1477 Error_Msg 1478 (Data.Flags, "include option cannot be null", 1479 Element.Value.Location, Project); 1480 end if; 1481 1482 Put (Into_List => Lang_Index.Config.Include_Option, 1483 From_List => List, 1484 In_Tree => Data.Tree); 1485 1486 -- Attribute Include_Path (<language>) 1487 1488 when Name_Include_Path => 1489 Lang_Index.Config.Include_Path := 1490 Element.Value.Value; 1491 1492 -- Attribute Include_Path_File (<language>) 1493 1494 when Name_Include_Path_File => 1495 Lang_Index.Config.Include_Path_File := 1496 Element.Value.Value; 1497 1498 -- Attribute Driver (<language>) 1499 1500 when Name_Driver => 1501 Lang_Index.Config.Compiler_Driver := 1502 File_Name_Type (Element.Value.Value); 1503 1504 when Name_Required_Switches 1505 | Name_Leading_Required_Switches 1506 => 1507 Put (Into_List => 1508 Lang_Index.Config. 1509 Compiler_Leading_Required_Switches, 1510 From_List => Element.Value.Values, 1511 In_Tree => Data.Tree); 1512 1513 when Name_Trailing_Required_Switches => 1514 Put (Into_List => 1515 Lang_Index.Config. 1516 Compiler_Trailing_Required_Switches, 1517 From_List => Element.Value.Values, 1518 In_Tree => Data.Tree); 1519 1520 when Name_Multi_Unit_Switches => 1521 Put (Into_List => 1522 Lang_Index.Config.Multi_Unit_Switches, 1523 From_List => Element.Value.Values, 1524 In_Tree => Data.Tree); 1525 1526 when Name_Multi_Unit_Object_Separator => 1527 Get_Name_String (Element.Value.Value); 1528 1529 if Name_Len /= 1 then 1530 Error_Msg 1531 (Data.Flags, 1532 "multi-unit object separator must have " & 1533 "a single character", 1534 Element.Value.Location, Project); 1535 1536 elsif Name_Buffer (1) = ' ' then 1537 Error_Msg 1538 (Data.Flags, 1539 "multi-unit object separator cannot be " & 1540 "a space", 1541 Element.Value.Location, Project); 1542 1543 else 1544 Lang_Index.Config.Multi_Unit_Object_Separator := 1545 Name_Buffer (1); 1546 end if; 1547 1548 when Name_Path_Syntax => 1549 begin 1550 Lang_Index.Config.Path_Syntax := 1551 Path_Syntax_Kind'Value 1552 (Get_Name_String (Element.Value.Value)); 1553 1554 exception 1555 when Constraint_Error => 1556 Error_Msg 1557 (Data.Flags, 1558 "invalid value for Path_Syntax", 1559 Element.Value.Location, Project); 1560 end; 1561 1562 when Name_Source_File_Switches => 1563 Put (Into_List => 1564 Lang_Index.Config.Source_File_Switches, 1565 From_List => Element.Value.Values, 1566 In_Tree => Data.Tree); 1567 1568 when Name_Object_File_Suffix => 1569 if Get_Name_String (Element.Value.Value) = "" then 1570 Error_Msg 1571 (Data.Flags, 1572 "object file suffix cannot be empty", 1573 Element.Value.Location, Project); 1574 1575 else 1576 Lang_Index.Config.Object_File_Suffix := 1577 Element.Value.Value; 1578 end if; 1579 1580 when Name_Object_File_Switches => 1581 Put (Into_List => 1582 Lang_Index.Config.Object_File_Switches, 1583 From_List => Element.Value.Values, 1584 In_Tree => Data.Tree); 1585 1586 when Name_Object_Path_Switches => 1587 Put (Into_List => 1588 Lang_Index.Config.Object_Path_Switches, 1589 From_List => Element.Value.Values, 1590 In_Tree => Data.Tree); 1591 1592 -- Attribute Compiler_Pic_Option (<language>) 1593 1594 when Name_Pic_Option => 1595 List := Element.Value.Values; 1596 1597 if List = Nil_String then 1598 Error_Msg 1599 (Data.Flags, 1600 "compiler PIC option cannot be null", 1601 Element.Value.Location, Project); 1602 end if; 1603 1604 Put (Into_List => 1605 Lang_Index.Config.Compilation_PIC_Option, 1606 From_List => List, 1607 In_Tree => Data.Tree); 1608 1609 -- Attribute Mapping_File_Switches (<language>) 1610 1611 when Name_Mapping_File_Switches => 1612 List := Element.Value.Values; 1613 1614 if List = Nil_String then 1615 Error_Msg 1616 (Data.Flags, 1617 "mapping file switches cannot be null", 1618 Element.Value.Location, Project); 1619 end if; 1620 1621 Put (Into_List => 1622 Lang_Index.Config.Mapping_File_Switches, 1623 From_List => List, 1624 In_Tree => Data.Tree); 1625 1626 -- Attribute Mapping_Spec_Suffix (<language>) 1627 1628 when Name_Mapping_Spec_Suffix => 1629 Lang_Index.Config.Mapping_Spec_Suffix := 1630 File_Name_Type (Element.Value.Value); 1631 1632 -- Attribute Mapping_Body_Suffix (<language>) 1633 1634 when Name_Mapping_Body_Suffix => 1635 Lang_Index.Config.Mapping_Body_Suffix := 1636 File_Name_Type (Element.Value.Value); 1637 1638 -- Attribute Config_File_Switches (<language>) 1639 1640 when Name_Config_File_Switches => 1641 List := Element.Value.Values; 1642 1643 if List = Nil_String then 1644 Error_Msg 1645 (Data.Flags, 1646 "config file switches cannot be null", 1647 Element.Value.Location, Project); 1648 end if; 1649 1650 Put (Into_List => 1651 Lang_Index.Config.Config_File_Switches, 1652 From_List => List, 1653 In_Tree => Data.Tree); 1654 1655 -- Attribute Objects_Path (<language>) 1656 1657 when Name_Objects_Path => 1658 Lang_Index.Config.Objects_Path := 1659 Element.Value.Value; 1660 1661 -- Attribute Objects_Path_File (<language>) 1662 1663 when Name_Objects_Path_File => 1664 Lang_Index.Config.Objects_Path_File := 1665 Element.Value.Value; 1666 1667 -- Attribute Config_Body_File_Name (<language>) 1668 1669 when Name_Config_Body_File_Name => 1670 Lang_Index.Config.Config_Body := 1671 Element.Value.Value; 1672 1673 -- Attribute Config_Body_File_Name_Index (< Language>) 1674 1675 when Name_Config_Body_File_Name_Index => 1676 Lang_Index.Config.Config_Body_Index := 1677 Element.Value.Value; 1678 1679 -- Attribute Config_Body_File_Name_Pattern(<language>) 1680 1681 when Name_Config_Body_File_Name_Pattern => 1682 Lang_Index.Config.Config_Body_Pattern := 1683 Element.Value.Value; 1684 1685 -- Attribute Config_Spec_File_Name (<language>) 1686 1687 when Name_Config_Spec_File_Name => 1688 Lang_Index.Config.Config_Spec := 1689 Element.Value.Value; 1690 1691 -- Attribute Config_Spec_File_Name_Index (<language>) 1692 1693 when Name_Config_Spec_File_Name_Index => 1694 Lang_Index.Config.Config_Spec_Index := 1695 Element.Value.Value; 1696 1697 -- Attribute Config_Spec_File_Name_Pattern(<language>) 1698 1699 when Name_Config_Spec_File_Name_Pattern => 1700 Lang_Index.Config.Config_Spec_Pattern := 1701 Element.Value.Value; 1702 1703 -- Attribute Config_File_Unique (<language>) 1704 1705 when Name_Config_File_Unique => 1706 begin 1707 Lang_Index.Config.Config_File_Unique := 1708 Boolean'Value 1709 (Get_Name_String (Element.Value.Value)); 1710 exception 1711 when Constraint_Error => 1712 Error_Msg 1713 (Data.Flags, 1714 "illegal value for Config_File_Unique", 1715 Element.Value.Location, Project); 1716 end; 1717 1718 when others => 1719 null; 1720 end case; 1721 end if; 1722 end if; 1723 1724 Element_Id := Element.Next; 1725 end loop; 1726 1727 Current_Array_Id := Current_Array.Next; 1728 end loop; 1729 end Process_Compiler; 1730 1731 -------------------- 1732 -- Process_Naming -- 1733 -------------------- 1734 1735 procedure Process_Naming (Attributes : Variable_Id) is 1736 Attribute_Id : Variable_Id; 1737 Attribute : Variable; 1738 1739 begin 1740 -- Process non associated array attribute from package Naming 1741 1742 Attribute_Id := Attributes; 1743 while Attribute_Id /= No_Variable loop 1744 Attribute := Shared.Variable_Elements.Table (Attribute_Id); 1745 1746 if not Attribute.Value.Default then 1747 if Attribute.Name = Name_Separate_Suffix then 1748 1749 -- Attribute Separate_Suffix 1750 1751 Get_Name_String (Attribute.Value.Value); 1752 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); 1753 Separate_Suffix := Name_Find; 1754 1755 elsif Attribute.Name = Name_Casing then 1756 1757 -- Attribute Casing 1758 1759 begin 1760 Casing := 1761 Value (Get_Name_String (Attribute.Value.Value)); 1762 1763 exception 1764 when Constraint_Error => 1765 Error_Msg 1766 (Data.Flags, 1767 "invalid value for Casing", 1768 Attribute.Value.Location, Project); 1769 end; 1770 1771 elsif Attribute.Name = Name_Dot_Replacement then 1772 1773 -- Attribute Dot_Replacement 1774 1775 Dot_Replacement := File_Name_Type (Attribute.Value.Value); 1776 1777 end if; 1778 end if; 1779 1780 Attribute_Id := Attribute.Next; 1781 end loop; 1782 end Process_Naming; 1783 1784 procedure Process_Naming (Arrays : Array_Id) is 1785 Current_Array_Id : Array_Id; 1786 Current_Array : Array_Data; 1787 Element_Id : Array_Element_Id; 1788 Element : Array_Element; 1789 1790 begin 1791 -- Process the associative array attribute of package Naming 1792 1793 Current_Array_Id := Arrays; 1794 while Current_Array_Id /= No_Array loop 1795 Current_Array := Shared.Arrays.Table (Current_Array_Id); 1796 1797 Element_Id := Current_Array.Value; 1798 while Element_Id /= No_Array_Element loop 1799 Element := Shared.Array_Elements.Table (Element_Id); 1800 1801 -- Get the name of the language 1802 1803 Lang_Index := Get_Language_From_Name 1804 (Project, Get_Name_String (Element.Index)); 1805 1806 if Lang_Index /= No_Language_Index 1807 and then Element.Value.Kind = Single 1808 and then Element.Value.Value /= No_Name 1809 then 1810 case Current_Array.Name is 1811 when Name_Spec_Suffix | Name_Specification_Suffix => 1812 1813 -- Attribute Spec_Suffix (<language>) 1814 1815 Get_Name_String (Element.Value.Value); 1816 Canonical_Case_File_Name 1817 (Name_Buffer (1 .. Name_Len)); 1818 Lang_Index.Config.Naming_Data.Spec_Suffix := 1819 Name_Find; 1820 1821 when Name_Implementation_Suffix | Name_Body_Suffix => 1822 1823 Get_Name_String (Element.Value.Value); 1824 Canonical_Case_File_Name 1825 (Name_Buffer (1 .. Name_Len)); 1826 1827 -- Attribute Body_Suffix (<language>) 1828 1829 Lang_Index.Config.Naming_Data.Body_Suffix := 1830 Name_Find; 1831 Lang_Index.Config.Naming_Data.Separate_Suffix := 1832 Lang_Index.Config.Naming_Data.Body_Suffix; 1833 1834 when others => 1835 null; 1836 end case; 1837 end if; 1838 1839 Element_Id := Element.Next; 1840 end loop; 1841 1842 Current_Array_Id := Current_Array.Next; 1843 end loop; 1844 end Process_Naming; 1845 1846 -------------------- 1847 -- Process_Linker -- 1848 -------------------- 1849 1850 procedure Process_Linker (Attributes : Variable_Id) is 1851 Attribute_Id : Variable_Id; 1852 Attribute : Variable; 1853 1854 begin 1855 -- Process non associated array attribute from package Linker 1856 1857 Attribute_Id := Attributes; 1858 while Attribute_Id /= No_Variable loop 1859 Attribute := Shared.Variable_Elements.Table (Attribute_Id); 1860 1861 if not Attribute.Value.Default then 1862 if Attribute.Name = Name_Driver then 1863 1864 -- Attribute Linker'Driver: the default linker to use 1865 1866 Project.Config.Linker := 1867 Path_Name_Type (Attribute.Value.Value); 1868 1869 -- Linker'Driver is also used to link shared libraries 1870 -- if the obsolescent attribute Library_GCC has not been 1871 -- specified. 1872 1873 if Project.Config.Shared_Lib_Driver = No_File then 1874 Project.Config.Shared_Lib_Driver := 1875 File_Name_Type (Attribute.Value.Value); 1876 end if; 1877 1878 elsif Attribute.Name = Name_Required_Switches then 1879 1880 -- Attribute Required_Switches: the minimum trailing 1881 -- options to use when invoking the linker 1882 1883 Put (Into_List => 1884 Project.Config.Trailing_Linker_Required_Switches, 1885 From_List => Attribute.Value.Values, 1886 In_Tree => Data.Tree); 1887 1888 elsif Attribute.Name = Name_Map_File_Option then 1889 Project.Config.Map_File_Option := Attribute.Value.Value; 1890 1891 elsif Attribute.Name = Name_Max_Command_Line_Length then 1892 begin 1893 Project.Config.Max_Command_Line_Length := 1894 Natural'Value (Get_Name_String 1895 (Attribute.Value.Value)); 1896 1897 exception 1898 when Constraint_Error => 1899 Error_Msg 1900 (Data.Flags, 1901 "value must be positive or equal to 0", 1902 Attribute.Value.Location, Project); 1903 end; 1904 1905 elsif Attribute.Name = Name_Response_File_Format then 1906 declare 1907 Name : Name_Id; 1908 1909 begin 1910 Get_Name_String (Attribute.Value.Value); 1911 To_Lower (Name_Buffer (1 .. Name_Len)); 1912 Name := Name_Find; 1913 1914 if Name = Name_None then 1915 Project.Config.Resp_File_Format := None; 1916 1917 elsif Name = Name_Gnu then 1918 Project.Config.Resp_File_Format := GNU; 1919 1920 elsif Name = Name_Object_List then 1921 Project.Config.Resp_File_Format := Object_List; 1922 1923 elsif Name = Name_Option_List then 1924 Project.Config.Resp_File_Format := Option_List; 1925 1926 elsif Name_Buffer (1 .. Name_Len) = "gcc" then 1927 Project.Config.Resp_File_Format := GCC; 1928 1929 elsif Name_Buffer (1 .. Name_Len) = "gcc_gnu" then 1930 Project.Config.Resp_File_Format := GCC_GNU; 1931 1932 elsif 1933 Name_Buffer (1 .. Name_Len) = "gcc_option_list" 1934 then 1935 Project.Config.Resp_File_Format := GCC_Option_List; 1936 1937 elsif 1938 Name_Buffer (1 .. Name_Len) = "gcc_object_list" 1939 then 1940 Project.Config.Resp_File_Format := GCC_Object_List; 1941 1942 else 1943 Error_Msg 1944 (Data.Flags, 1945 "illegal response file format", 1946 Attribute.Value.Location, Project); 1947 end if; 1948 end; 1949 1950 elsif Attribute.Name = Name_Response_File_Switches then 1951 Put (Into_List => Project.Config.Resp_File_Options, 1952 From_List => Attribute.Value.Values, 1953 In_Tree => Data.Tree); 1954 end if; 1955 end if; 1956 1957 Attribute_Id := Attribute.Next; 1958 end loop; 1959 end Process_Linker; 1960 1961 -- Start of processing for Process_Packages 1962 1963 begin 1964 Packages := Project.Decl.Packages; 1965 while Packages /= No_Package loop 1966 Element := Shared.Packages.Table (Packages); 1967 1968 case Element.Name is 1969 when Name_Binder => 1970 1971 -- Process attributes of package Binder 1972 1973 Process_Binder (Element.Decl.Arrays); 1974 1975 when Name_Builder => 1976 1977 -- Process attributes of package Builder 1978 1979 Process_Builder (Element.Decl.Attributes); 1980 1981 when Name_Clean => 1982 1983 -- Process attributes of package Clean 1984 1985 Process_Clean (Element.Decl.Attributes); 1986 Process_Clean (Element.Decl.Arrays); 1987 1988 when Name_Compiler => 1989 1990 -- Process attributes of package Compiler 1991 1992 Process_Compiler (Element.Decl.Arrays); 1993 1994 when Name_Linker => 1995 1996 -- Process attributes of package Linker 1997 1998 Process_Linker (Element.Decl.Attributes); 1999 2000 when Name_Naming => 2001 2002 -- Process attributes of package Naming 2003 2004 Process_Naming (Element.Decl.Attributes); 2005 Process_Naming (Element.Decl.Arrays); 2006 2007 when others => 2008 null; 2009 end case; 2010 2011 Packages := Element.Next; 2012 end loop; 2013 end Process_Packages; 2014 2015 --------------------------------------------- 2016 -- Process_Project_Level_Simple_Attributes -- 2017 --------------------------------------------- 2018 2019 procedure Process_Project_Level_Simple_Attributes is 2020 Attribute_Id : Variable_Id; 2021 Attribute : Variable; 2022 List : String_List_Id; 2023 2024 begin 2025 -- Process non associated array attribute at project level 2026 2027 Attribute_Id := Project.Decl.Attributes; 2028 while Attribute_Id /= No_Variable loop 2029 Attribute := Shared.Variable_Elements.Table (Attribute_Id); 2030 2031 if not Attribute.Value.Default then 2032 if Attribute.Name = Name_Target then 2033 2034 -- Attribute Target: the target specified 2035 2036 Project.Config.Target := Attribute.Value.Value; 2037 2038 elsif Attribute.Name = Name_Library_Builder then 2039 2040 -- Attribute Library_Builder: the application to invoke 2041 -- to build libraries. 2042 2043 Project.Config.Library_Builder := 2044 Path_Name_Type (Attribute.Value.Value); 2045 2046 elsif Attribute.Name = Name_Archive_Builder then 2047 2048 -- Attribute Archive_Builder: the archive builder 2049 -- (usually "ar") and its minimum options (usually "cr"). 2050 2051 List := Attribute.Value.Values; 2052 2053 if List = Nil_String then 2054 Error_Msg 2055 (Data.Flags, 2056 "archive builder cannot be null", 2057 Attribute.Value.Location, Project); 2058 end if; 2059 2060 Put (Into_List => Project.Config.Archive_Builder, 2061 From_List => List, 2062 In_Tree => Data.Tree); 2063 2064 elsif Attribute.Name = Name_Archive_Builder_Append_Option then 2065 2066 -- Attribute Archive_Builder: the archive builder 2067 -- (usually "ar") and its minimum options (usually "cr"). 2068 2069 List := Attribute.Value.Values; 2070 2071 if List /= Nil_String then 2072 Put 2073 (Into_List => 2074 Project.Config.Archive_Builder_Append_Option, 2075 From_List => List, 2076 In_Tree => Data.Tree); 2077 end if; 2078 2079 elsif Attribute.Name = Name_Archive_Indexer then 2080 2081 -- Attribute Archive_Indexer: the optional archive 2082 -- indexer (usually "ranlib") with its minimum options 2083 -- (usually none). 2084 2085 List := Attribute.Value.Values; 2086 2087 if List = Nil_String then 2088 Error_Msg 2089 (Data.Flags, 2090 "archive indexer cannot be null", 2091 Attribute.Value.Location, Project); 2092 end if; 2093 2094 Put (Into_List => Project.Config.Archive_Indexer, 2095 From_List => List, 2096 In_Tree => Data.Tree); 2097 2098 elsif Attribute.Name = Name_Library_Partial_Linker then 2099 2100 -- Attribute Library_Partial_Linker: the optional linker 2101 -- driver with its minimum options, to partially link 2102 -- archives. 2103 2104 List := Attribute.Value.Values; 2105 2106 if List = Nil_String then 2107 Error_Msg 2108 (Data.Flags, 2109 "partial linker cannot be null", 2110 Attribute.Value.Location, Project); 2111 end if; 2112 2113 Put (Into_List => Project.Config.Lib_Partial_Linker, 2114 From_List => List, 2115 In_Tree => Data.Tree); 2116 2117 elsif Attribute.Name = Name_Library_GCC then 2118 Project.Config.Shared_Lib_Driver := 2119 File_Name_Type (Attribute.Value.Value); 2120 Error_Msg 2121 (Data.Flags, 2122 "?Library_'G'C'C is an obsolescent attribute, " & 2123 "use Linker''Driver instead", 2124 Attribute.Value.Location, Project); 2125 2126 elsif Attribute.Name = Name_Archive_Suffix then 2127 Project.Config.Archive_Suffix := 2128 File_Name_Type (Attribute.Value.Value); 2129 2130 elsif Attribute.Name = Name_Linker_Executable_Option then 2131 2132 -- Attribute Linker_Executable_Option: optional options 2133 -- to specify an executable name. Defaults to "-o". 2134 2135 List := Attribute.Value.Values; 2136 2137 if List = Nil_String then 2138 Error_Msg 2139 (Data.Flags, 2140 "linker executable option cannot be null", 2141 Attribute.Value.Location, Project); 2142 end if; 2143 2144 Put (Into_List => Project.Config.Linker_Executable_Option, 2145 From_List => List, 2146 In_Tree => Data.Tree); 2147 2148 elsif Attribute.Name = Name_Linker_Lib_Dir_Option then 2149 2150 -- Attribute Linker_Lib_Dir_Option: optional options 2151 -- to specify a library search directory. Defaults to 2152 -- "-L". 2153 2154 Get_Name_String (Attribute.Value.Value); 2155 2156 if Name_Len = 0 then 2157 Error_Msg 2158 (Data.Flags, 2159 "linker library directory option cannot be empty", 2160 Attribute.Value.Location, Project); 2161 end if; 2162 2163 Project.Config.Linker_Lib_Dir_Option := 2164 Attribute.Value.Value; 2165 2166 elsif Attribute.Name = Name_Linker_Lib_Name_Option then 2167 2168 -- Attribute Linker_Lib_Name_Option: optional options 2169 -- to specify the name of a library to be linked in. 2170 -- Defaults to "-l". 2171 2172 Get_Name_String (Attribute.Value.Value); 2173 2174 if Name_Len = 0 then 2175 Error_Msg 2176 (Data.Flags, 2177 "linker library name option cannot be empty", 2178 Attribute.Value.Location, Project); 2179 end if; 2180 2181 Project.Config.Linker_Lib_Name_Option := 2182 Attribute.Value.Value; 2183 2184 elsif Attribute.Name = Name_Run_Path_Option then 2185 2186 -- Attribute Run_Path_Option: optional options to 2187 -- specify a path for libraries. 2188 2189 List := Attribute.Value.Values; 2190 2191 if List /= Nil_String then 2192 Put (Into_List => Project.Config.Run_Path_Option, 2193 From_List => List, 2194 In_Tree => Data.Tree); 2195 end if; 2196 2197 elsif Attribute.Name = Name_Run_Path_Origin then 2198 Get_Name_String (Attribute.Value.Value); 2199 2200 if Name_Len = 0 then 2201 Error_Msg 2202 (Data.Flags, 2203 "run path origin cannot be empty", 2204 Attribute.Value.Location, Project); 2205 end if; 2206 2207 Project.Config.Run_Path_Origin := Attribute.Value.Value; 2208 2209 elsif Attribute.Name = Name_Library_Install_Name_Option then 2210 Project.Config.Library_Install_Name_Option := 2211 Attribute.Value.Value; 2212 2213 elsif Attribute.Name = Name_Separate_Run_Path_Options then 2214 declare 2215 pragma Unsuppress (All_Checks); 2216 begin 2217 Project.Config.Separate_Run_Path_Options := 2218 Boolean'Value (Get_Name_String (Attribute.Value.Value)); 2219 exception 2220 when Constraint_Error => 2221 Error_Msg 2222 (Data.Flags, 2223 "invalid value """ & 2224 Get_Name_String (Attribute.Value.Value) & 2225 """ for Separate_Run_Path_Options", 2226 Attribute.Value.Location, Project); 2227 end; 2228 2229 elsif Attribute.Name = Name_Library_Support then 2230 declare 2231 pragma Unsuppress (All_Checks); 2232 begin 2233 Project.Config.Lib_Support := 2234 Library_Support'Value (Get_Name_String 2235 (Attribute.Value.Value)); 2236 exception 2237 when Constraint_Error => 2238 Error_Msg 2239 (Data.Flags, 2240 "invalid value """ & 2241 Get_Name_String (Attribute.Value.Value) & 2242 """ for Library_Support", 2243 Attribute.Value.Location, Project); 2244 end; 2245 2246 elsif 2247 Attribute.Name = Name_Library_Encapsulated_Supported 2248 then 2249 declare 2250 pragma Unsuppress (All_Checks); 2251 begin 2252 Project.Config.Lib_Encapsulated_Supported := 2253 Boolean'Value (Get_Name_String (Attribute.Value.Value)); 2254 exception 2255 when Constraint_Error => 2256 Error_Msg 2257 (Data.Flags, 2258 "invalid value """ 2259 & Get_Name_String (Attribute.Value.Value) 2260 & """ for Library_Encapsulated_Supported", 2261 Attribute.Value.Location, Project); 2262 end; 2263 2264 elsif Attribute.Name = Name_Shared_Library_Prefix then 2265 Project.Config.Shared_Lib_Prefix := 2266 File_Name_Type (Attribute.Value.Value); 2267 2268 elsif Attribute.Name = Name_Shared_Library_Suffix then 2269 Project.Config.Shared_Lib_Suffix := 2270 File_Name_Type (Attribute.Value.Value); 2271 2272 elsif Attribute.Name = Name_Symbolic_Link_Supported then 2273 declare 2274 pragma Unsuppress (All_Checks); 2275 begin 2276 Project.Config.Symbolic_Link_Supported := 2277 Boolean'Value (Get_Name_String 2278 (Attribute.Value.Value)); 2279 exception 2280 when Constraint_Error => 2281 Error_Msg 2282 (Data.Flags, 2283 "invalid value """ 2284 & Get_Name_String (Attribute.Value.Value) 2285 & """ for Symbolic_Link_Supported", 2286 Attribute.Value.Location, Project); 2287 end; 2288 2289 elsif 2290 Attribute.Name = Name_Library_Major_Minor_Id_Supported 2291 then 2292 declare 2293 pragma Unsuppress (All_Checks); 2294 begin 2295 Project.Config.Lib_Maj_Min_Id_Supported := 2296 Boolean'Value (Get_Name_String 2297 (Attribute.Value.Value)); 2298 exception 2299 when Constraint_Error => 2300 Error_Msg 2301 (Data.Flags, 2302 "invalid value """ & 2303 Get_Name_String (Attribute.Value.Value) & 2304 """ for Library_Major_Minor_Id_Supported", 2305 Attribute.Value.Location, Project); 2306 end; 2307 2308 elsif Attribute.Name = Name_Library_Auto_Init_Supported then 2309 declare 2310 pragma Unsuppress (All_Checks); 2311 begin 2312 Project.Config.Auto_Init_Supported := 2313 Boolean'Value (Get_Name_String (Attribute.Value.Value)); 2314 exception 2315 when Constraint_Error => 2316 Error_Msg 2317 (Data.Flags, 2318 "invalid value """ 2319 & Get_Name_String (Attribute.Value.Value) 2320 & """ for Library_Auto_Init_Supported", 2321 Attribute.Value.Location, Project); 2322 end; 2323 2324 elsif Attribute.Name = Name_Shared_Library_Minimum_Switches then 2325 List := Attribute.Value.Values; 2326 2327 if List /= Nil_String then 2328 Put (Into_List => Project.Config.Shared_Lib_Min_Options, 2329 From_List => List, 2330 In_Tree => Data.Tree); 2331 end if; 2332 2333 elsif Attribute.Name = Name_Library_Version_Switches then 2334 List := Attribute.Value.Values; 2335 2336 if List /= Nil_String then 2337 Put (Into_List => Project.Config.Lib_Version_Options, 2338 From_List => List, 2339 In_Tree => Data.Tree); 2340 end if; 2341 end if; 2342 end if; 2343 2344 Attribute_Id := Attribute.Next; 2345 end loop; 2346 end Process_Project_Level_Simple_Attributes; 2347 2348 -------------------------------------------- 2349 -- Process_Project_Level_Array_Attributes -- 2350 -------------------------------------------- 2351 2352 procedure Process_Project_Level_Array_Attributes is 2353 Current_Array_Id : Array_Id; 2354 Current_Array : Array_Data; 2355 Element_Id : Array_Element_Id; 2356 Element : Array_Element; 2357 List : String_List_Id; 2358 2359 begin 2360 -- Process the associative array attributes at project level 2361 2362 Current_Array_Id := Project.Decl.Arrays; 2363 while Current_Array_Id /= No_Array loop 2364 Current_Array := Shared.Arrays.Table (Current_Array_Id); 2365 2366 Element_Id := Current_Array.Value; 2367 while Element_Id /= No_Array_Element loop 2368 Element := Shared.Array_Elements.Table (Element_Id); 2369 2370 -- Get the name of the language 2371 2372 Lang_Index := 2373 Get_Language_From_Name 2374 (Project, Get_Name_String (Element.Index)); 2375 2376 if Lang_Index /= No_Language_Index then 2377 case Current_Array.Name is 2378 when Name_Inherit_Source_Path => 2379 List := Element.Value.Values; 2380 2381 if List /= Nil_String then 2382 Put 2383 (Into_List => 2384 Lang_Index.Config.Include_Compatible_Languages, 2385 From_List => List, 2386 In_Tree => Data.Tree, 2387 Lower_Case => True); 2388 end if; 2389 2390 when Name_Toolchain_Description => 2391 2392 -- Attribute Toolchain_Description (<language>) 2393 2394 Lang_Index.Config.Toolchain_Description := 2395 Element.Value.Value; 2396 2397 when Name_Toolchain_Version => 2398 2399 -- Attribute Toolchain_Version (<language>) 2400 2401 Lang_Index.Config.Toolchain_Version := 2402 Element.Value.Value; 2403 2404 -- For Ada, set proper checksum computation mode, 2405 -- which has changed from version to version. 2406 2407 if Lang_Index.Name = Name_Ada then 2408 declare 2409 Vers : constant String := 2410 Get_Name_String (Element.Value.Value); 2411 pragma Assert (Vers'First = 1); 2412 2413 begin 2414 -- Version 6.3 or earlier 2415 2416 if Vers'Length >= 8 2417 and then Vers (1 .. 5) = "GNAT " 2418 and then Vers (7) = '.' 2419 and then 2420 (Vers (6) < '6' 2421 or else 2422 (Vers (6) = '6' and then Vers (8) < '4')) 2423 then 2424 Checksum_GNAT_6_3 := True; 2425 2426 -- Version 5.03 or earlier 2427 2428 if Vers (6) < '5' 2429 or else (Vers (6) = '5' 2430 and then Vers (Vers'Last) < '4') 2431 then 2432 Checksum_GNAT_5_03 := True; 2433 2434 -- Version 5.02 or earlier (no checksums) 2435 2436 if Vers (6) /= '5' 2437 or else Vers (Vers'Last) < '3' 2438 then 2439 Checksum_Accumulate_Token_Checksum := 2440 False; 2441 end if; 2442 end if; 2443 end if; 2444 end; 2445 end if; 2446 2447 when Name_Runtime_Library_Dir => 2448 2449 -- Attribute Runtime_Library_Dir (<language>) 2450 2451 Lang_Index.Config.Runtime_Library_Dir := 2452 Element.Value.Value; 2453 2454 when Name_Runtime_Source_Dir => 2455 2456 -- Attribute Runtime_Source_Dir (<language>) 2457 2458 Lang_Index.Config.Runtime_Source_Dir := 2459 Element.Value.Value; 2460 2461 when Name_Object_Generated => 2462 declare 2463 pragma Unsuppress (All_Checks); 2464 Value : Boolean; 2465 2466 begin 2467 Value := 2468 Boolean'Value 2469 (Get_Name_String (Element.Value.Value)); 2470 2471 Lang_Index.Config.Object_Generated := Value; 2472 2473 -- If no object is generated, no object may be 2474 -- linked. 2475 2476 if not Value then 2477 Lang_Index.Config.Objects_Linked := False; 2478 end if; 2479 2480 exception 2481 when Constraint_Error => 2482 Error_Msg 2483 (Data.Flags, 2484 "invalid value """ 2485 & Get_Name_String (Element.Value.Value) 2486 & """ for Object_Generated", 2487 Element.Value.Location, Project); 2488 end; 2489 2490 when Name_Objects_Linked => 2491 declare 2492 pragma Unsuppress (All_Checks); 2493 Value : Boolean; 2494 2495 begin 2496 Value := 2497 Boolean'Value 2498 (Get_Name_String (Element.Value.Value)); 2499 2500 -- No change if Object_Generated is False, as this 2501 -- forces Objects_Linked to be False too. 2502 2503 if Lang_Index.Config.Object_Generated then 2504 Lang_Index.Config.Objects_Linked := Value; 2505 end if; 2506 2507 exception 2508 when Constraint_Error => 2509 Error_Msg 2510 (Data.Flags, 2511 "invalid value """ 2512 & Get_Name_String (Element.Value.Value) 2513 & """ for Objects_Linked", 2514 Element.Value.Location, Project); 2515 end; 2516 when others => 2517 null; 2518 end case; 2519 end if; 2520 2521 Element_Id := Element.Next; 2522 end loop; 2523 2524 Current_Array_Id := Current_Array.Next; 2525 end loop; 2526 end Process_Project_Level_Array_Attributes; 2527 2528 -- Start of processing for Check_Configuration 2529 2530 begin 2531 Process_Project_Level_Simple_Attributes; 2532 Process_Project_Level_Array_Attributes; 2533 Process_Packages; 2534 2535 -- For unit based languages, set Casing, Dot_Replacement and 2536 -- Separate_Suffix in Naming_Data. 2537 2538 Lang_Index := Project.Languages; 2539 while Lang_Index /= No_Language_Index loop 2540 if Lang_Index.Config.Kind = Unit_Based then 2541 Lang_Index.Config.Naming_Data.Casing := Casing; 2542 Lang_Index.Config.Naming_Data.Dot_Replacement := Dot_Replacement; 2543 2544 if Separate_Suffix /= No_File then 2545 Lang_Index.Config.Naming_Data.Separate_Suffix := 2546 Separate_Suffix; 2547 end if; 2548 2549 exit; 2550 end if; 2551 2552 Lang_Index := Lang_Index.Next; 2553 end loop; 2554 2555 -- Give empty names to various prefixes/suffixes, if they have not 2556 -- been specified in the configuration. 2557 2558 if Project.Config.Archive_Suffix = No_File then 2559 Project.Config.Archive_Suffix := Empty_File; 2560 end if; 2561 2562 if Project.Config.Shared_Lib_Prefix = No_File then 2563 Project.Config.Shared_Lib_Prefix := Empty_File; 2564 end if; 2565 2566 if Project.Config.Shared_Lib_Suffix = No_File then 2567 Project.Config.Shared_Lib_Suffix := Empty_File; 2568 end if; 2569 2570 Lang_Index := Project.Languages; 2571 while Lang_Index /= No_Language_Index loop 2572 2573 -- For all languages, Compiler_Driver needs to be specified. This is 2574 -- only needed if we do intend to compile (not in GPS for instance). 2575 2576 if Data.Flags.Compiler_Driver_Mandatory 2577 and then Lang_Index.Config.Compiler_Driver = No_File 2578 and then not Project.Externally_Built 2579 then 2580 Error_Msg_Name_1 := Lang_Index.Display_Name; 2581 Error_Msg 2582 (Data.Flags, 2583 "?\no compiler specified for language %%" & 2584 ", ignoring all its sources", 2585 No_Location, Project); 2586 2587 if Lang_Index = Project.Languages then 2588 Project.Languages := Lang_Index.Next; 2589 else 2590 Prev_Index.Next := Lang_Index.Next; 2591 end if; 2592 2593 elsif Lang_Index.Config.Kind = Unit_Based then 2594 Prev_Index := Lang_Index; 2595 2596 -- For unit based languages, Dot_Replacement, Spec_Suffix and 2597 -- Body_Suffix need to be specified. 2598 2599 if Lang_Index.Config.Naming_Data.Dot_Replacement = No_File then 2600 Error_Msg 2601 (Data.Flags, 2602 "Dot_Replacement not specified for " & 2603 Get_Name_String (Lang_Index.Name), 2604 No_Location, Project); 2605 end if; 2606 2607 if Lang_Index.Config.Naming_Data.Spec_Suffix = No_File then 2608 Error_Msg 2609 (Data.Flags, 2610 "\Spec_Suffix not specified for " & 2611 Get_Name_String (Lang_Index.Name), 2612 No_Location, Project); 2613 end if; 2614 2615 if Lang_Index.Config.Naming_Data.Body_Suffix = No_File then 2616 Error_Msg 2617 (Data.Flags, 2618 "\Body_Suffix not specified for " & 2619 Get_Name_String (Lang_Index.Name), 2620 No_Location, Project); 2621 end if; 2622 2623 else 2624 Prev_Index := Lang_Index; 2625 2626 -- For file based languages, either Spec_Suffix or Body_Suffix 2627 -- need to be specified. 2628 2629 if Data.Flags.Require_Sources_Other_Lang 2630 and then Lang_Index.Config.Naming_Data.Spec_Suffix = No_File 2631 and then Lang_Index.Config.Naming_Data.Body_Suffix = No_File 2632 then 2633 Error_Msg_Name_1 := Lang_Index.Display_Name; 2634 Error_Msg 2635 (Data.Flags, 2636 "\no suffixes specified for %%", 2637 No_Location, Project); 2638 end if; 2639 end if; 2640 2641 Lang_Index := Lang_Index.Next; 2642 end loop; 2643 end Check_Configuration; 2644 2645 ------------------------------- 2646 -- Check_If_Externally_Built -- 2647 ------------------------------- 2648 2649 procedure Check_If_Externally_Built 2650 (Project : Project_Id; 2651 Data : in out Tree_Processing_Data) 2652 is 2653 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; 2654 Externally_Built : constant Variable_Value := 2655 Util.Value_Of 2656 (Name_Externally_Built, 2657 Project.Decl.Attributes, Shared); 2658 2659 begin 2660 if not Externally_Built.Default then 2661 Get_Name_String (Externally_Built.Value); 2662 To_Lower (Name_Buffer (1 .. Name_Len)); 2663 2664 if Name_Buffer (1 .. Name_Len) = "true" then 2665 Project.Externally_Built := True; 2666 2667 elsif Name_Buffer (1 .. Name_Len) /= "false" then 2668 Error_Msg (Data.Flags, 2669 "Externally_Built may only be true or false", 2670 Externally_Built.Location, Project); 2671 end if; 2672 end if; 2673 2674 -- A virtual project extending an externally built project is itself 2675 -- externally built. 2676 2677 if Project.Virtual and then Project.Extends /= No_Project then 2678 Project.Externally_Built := Project.Extends.Externally_Built; 2679 end if; 2680 2681 if Project.Externally_Built then 2682 Debug_Output ("project is externally built"); 2683 else 2684 Debug_Output ("project is not externally built"); 2685 end if; 2686 end Check_If_Externally_Built; 2687 2688 ---------------------- 2689 -- Check_Interfaces -- 2690 ---------------------- 2691 2692 procedure Check_Interfaces 2693 (Project : Project_Id; 2694 Data : in out Tree_Processing_Data) 2695 is 2696 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; 2697 2698 Interfaces : constant Prj.Variable_Value := 2699 Prj.Util.Value_Of 2700 (Snames.Name_Interfaces, 2701 Project.Decl.Attributes, 2702 Shared); 2703 2704 Library_Interface : constant Prj.Variable_Value := 2705 Prj.Util.Value_Of 2706 (Snames.Name_Library_Interface, 2707 Project.Decl.Attributes, 2708 Shared); 2709 2710 List : String_List_Id; 2711 Element : String_Element; 2712 Name : File_Name_Type; 2713 Iter : Source_Iterator; 2714 Source : Source_Id; 2715 Project_2 : Project_Id; 2716 Other : Source_Id; 2717 Unit_Found : Boolean; 2718 2719 Interface_ALIs : String_List_Id := Nil_String; 2720 Other_Interfaces : String_List_Id := Nil_String; 2721 2722 begin 2723 if not Interfaces.Default then 2724 2725 -- Set In_Interfaces to False for all sources. It will be set to True 2726 -- later for the sources in the Interfaces list. 2727 2728 Project_2 := Project; 2729 while Project_2 /= No_Project loop 2730 Iter := For_Each_Source (Data.Tree, Project_2); 2731 loop 2732 Source := Prj.Element (Iter); 2733 exit when Source = No_Source; 2734 Source.In_Interfaces := False; 2735 Next (Iter); 2736 end loop; 2737 2738 Project_2 := Project_2.Extends; 2739 end loop; 2740 2741 List := Interfaces.Values; 2742 while List /= Nil_String loop 2743 Element := Shared.String_Elements.Table (List); 2744 Name := Canonical_Case_File_Name (Element.Value); 2745 2746 Project_2 := Project; 2747 Big_Loop : while Project_2 /= No_Project loop 2748 if Project.Qualifier = Aggregate_Library then 2749 2750 -- For an aggregate library we want to consider sources of 2751 -- all aggregated projects. 2752 2753 Iter := For_Each_Source (Data.Tree); 2754 2755 else 2756 Iter := For_Each_Source (Data.Tree, Project_2); 2757 end if; 2758 2759 loop 2760 Source := Prj.Element (Iter); 2761 exit when Source = No_Source; 2762 2763 if Source.File = Name then 2764 if not Source.Locally_Removed then 2765 Source.In_Interfaces := True; 2766 Source.Declared_In_Interfaces := True; 2767 2768 Other := Other_Part (Source); 2769 2770 if Other /= No_Source then 2771 Other.In_Interfaces := True; 2772 Other.Declared_In_Interfaces := True; 2773 end if; 2774 2775 -- Unit based case 2776 2777 if Source.Language.Config.Kind = Unit_Based then 2778 if Source.Kind = Spec 2779 and then Other_Part (Source) /= No_Source 2780 then 2781 Source := Other_Part (Source); 2782 end if; 2783 2784 String_Element_Table.Increment_Last 2785 (Shared.String_Elements); 2786 2787 Shared.String_Elements.Table 2788 (String_Element_Table.Last 2789 (Shared.String_Elements)) := 2790 (Value => Name_Id (Source.Dep_Name), 2791 Index => 0, 2792 Display_Value => Name_Id (Source.Dep_Name), 2793 Location => No_Location, 2794 Flag => False, 2795 Next => Interface_ALIs); 2796 2797 Interface_ALIs := 2798 String_Element_Table.Last 2799 (Shared.String_Elements); 2800 2801 -- File based case 2802 2803 else 2804 String_Element_Table.Increment_Last 2805 (Shared.String_Elements); 2806 2807 Shared.String_Elements.Table 2808 (String_Element_Table.Last 2809 (Shared.String_Elements)) := 2810 (Value => Name_Id (Source.File), 2811 Index => 0, 2812 Display_Value => Name_Id (Source.Display_File), 2813 Location => No_Location, 2814 Flag => False, 2815 Next => Other_Interfaces); 2816 2817 Other_Interfaces := 2818 String_Element_Table.Last 2819 (Shared.String_Elements); 2820 end if; 2821 2822 Debug_Output 2823 ("interface: ", Name_Id (Source.Path.Name)); 2824 end if; 2825 2826 exit Big_Loop; 2827 end if; 2828 2829 Next (Iter); 2830 end loop; 2831 2832 Project_2 := Project_2.Extends; 2833 end loop Big_Loop; 2834 2835 if Source = No_Source then 2836 Error_Msg_File_1 := File_Name_Type (Element.Value); 2837 Error_Msg_Name_1 := Project.Name; 2838 2839 Error_Msg 2840 (Data.Flags, 2841 "{ cannot be an interface of project %% " 2842 & "as it is not one of its sources", 2843 Element.Location, Project); 2844 end if; 2845 2846 List := Element.Next; 2847 end loop; 2848 2849 Project.Interfaces_Defined := True; 2850 Project.Lib_Interface_ALIs := Interface_ALIs; 2851 Project.Other_Interfaces := Other_Interfaces; 2852 2853 elsif Project.Library and then not Library_Interface.Default then 2854 2855 -- Set In_Interfaces to False for all sources. It will be set to True 2856 -- later for the sources in the Library_Interface list. 2857 2858 Project_2 := Project; 2859 while Project_2 /= No_Project loop 2860 Iter := For_Each_Source (Data.Tree, Project_2); 2861 loop 2862 Source := Prj.Element (Iter); 2863 exit when Source = No_Source; 2864 Source.In_Interfaces := False; 2865 Next (Iter); 2866 end loop; 2867 2868 Project_2 := Project_2.Extends; 2869 end loop; 2870 2871 List := Library_Interface.Values; 2872 while List /= Nil_String loop 2873 Element := Shared.String_Elements.Table (List); 2874 Get_Name_String (Element.Value); 2875 To_Lower (Name_Buffer (1 .. Name_Len)); 2876 Name := Name_Find; 2877 Unit_Found := False; 2878 2879 Project_2 := Project; 2880 Big_Loop_2 : while Project_2 /= No_Project loop 2881 if Project.Qualifier = Aggregate_Library then 2882 2883 -- For an aggregate library we want to consider sources of 2884 -- all aggregated projects. 2885 2886 Iter := For_Each_Source (Data.Tree); 2887 2888 else 2889 Iter := For_Each_Source (Data.Tree, Project_2); 2890 end if; 2891 2892 loop 2893 Source := Prj.Element (Iter); 2894 exit when Source = No_Source; 2895 2896 if Source.Unit /= No_Unit_Index 2897 and then Source.Unit.Name = Name_Id (Name) 2898 then 2899 if not Source.Locally_Removed then 2900 Source.In_Interfaces := True; 2901 Source.Declared_In_Interfaces := True; 2902 Project.Interfaces_Defined := True; 2903 2904 Other := Other_Part (Source); 2905 2906 if Other /= No_Source then 2907 Other.In_Interfaces := True; 2908 Other.Declared_In_Interfaces := True; 2909 end if; 2910 2911 Debug_Output 2912 ("interface: ", Name_Id (Source.Path.Name)); 2913 2914 if Source.Kind = Spec 2915 and then Other_Part (Source) /= No_Source 2916 then 2917 Source := Other_Part (Source); 2918 end if; 2919 2920 String_Element_Table.Increment_Last 2921 (Shared.String_Elements); 2922 2923 Shared.String_Elements.Table 2924 (String_Element_Table.Last 2925 (Shared.String_Elements)) := 2926 (Value => Name_Id (Source.Dep_Name), 2927 Index => 0, 2928 Display_Value => Name_Id (Source.Dep_Name), 2929 Location => No_Location, 2930 Flag => False, 2931 Next => Interface_ALIs); 2932 2933 Interface_ALIs := 2934 String_Element_Table.Last (Shared.String_Elements); 2935 end if; 2936 2937 Unit_Found := True; 2938 exit Big_Loop_2; 2939 end if; 2940 2941 Next (Iter); 2942 end loop; 2943 2944 Project_2 := Project_2.Extends; 2945 end loop Big_Loop_2; 2946 2947 if not Unit_Found then 2948 Error_Msg_Name_1 := Name_Id (Name); 2949 2950 Error_Msg 2951 (Data.Flags, 2952 "%% is not a unit of this project", 2953 Element.Location, Project); 2954 end if; 2955 2956 List := Element.Next; 2957 end loop; 2958 2959 Project.Lib_Interface_ALIs := Interface_ALIs; 2960 2961 elsif Project.Extends /= No_Project 2962 and then Project.Extends.Interfaces_Defined 2963 then 2964 Project.Interfaces_Defined := True; 2965 2966 Iter := For_Each_Source (Data.Tree, Project); 2967 loop 2968 Source := Prj.Element (Iter); 2969 exit when Source = No_Source; 2970 2971 if not Source.Declared_In_Interfaces then 2972 Source.In_Interfaces := False; 2973 end if; 2974 2975 Next (Iter); 2976 end loop; 2977 2978 Project.Lib_Interface_ALIs := Project.Extends.Lib_Interface_ALIs; 2979 end if; 2980 end Check_Interfaces; 2981 2982 ------------------------------ 2983 -- Check_Library_Attributes -- 2984 ------------------------------ 2985 2986 -- This procedure is awfully long (over 700 lines) should be broken up??? 2987 2988 procedure Check_Library_Attributes 2989 (Project : Project_Id; 2990 Data : in out Tree_Processing_Data) 2991 is 2992 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; 2993 2994 Attributes : constant Prj.Variable_Id := Project.Decl.Attributes; 2995 2996 Lib_Dir : constant Prj.Variable_Value := 2997 Prj.Util.Value_Of 2998 (Snames.Name_Library_Dir, Attributes, Shared); 2999 3000 Lib_Name : constant Prj.Variable_Value := 3001 Prj.Util.Value_Of 3002 (Snames.Name_Library_Name, Attributes, Shared); 3003 3004 Lib_Standalone : constant Prj.Variable_Value := 3005 Prj.Util.Value_Of 3006 (Snames.Name_Library_Standalone, 3007 Attributes, Shared); 3008 3009 Lib_Version : constant Prj.Variable_Value := 3010 Prj.Util.Value_Of 3011 (Snames.Name_Library_Version, Attributes, Shared); 3012 3013 Lib_ALI_Dir : constant Prj.Variable_Value := 3014 Prj.Util.Value_Of 3015 (Snames.Name_Library_Ali_Dir, Attributes, Shared); 3016 3017 Lib_GCC : constant Prj.Variable_Value := 3018 Prj.Util.Value_Of 3019 (Snames.Name_Library_GCC, Attributes, Shared); 3020 3021 The_Lib_Kind : constant Prj.Variable_Value := 3022 Prj.Util.Value_Of 3023 (Snames.Name_Library_Kind, Attributes, Shared); 3024 3025 Imported_Project_List : Project_List; 3026 Continuation : String_Access := No_Continuation_String'Access; 3027 Support_For_Libraries : Library_Support; 3028 3029 Library_Directory_Present : Boolean; 3030 3031 procedure Check_Library (Proj : Project_Id; Extends : Boolean); 3032 -- Check if an imported or extended project if also a library project 3033 3034 procedure Check_Aggregate_Library_Dirs; 3035 -- Check that the library directory and the library ALI directory of an 3036 -- aggregate library project are not the same as the object directory or 3037 -- the library directory of any of its aggregated projects. 3038 3039 ---------------------------------- 3040 -- Check_Aggregate_Library_Dirs -- 3041 ---------------------------------- 3042 3043 procedure Check_Aggregate_Library_Dirs is 3044 procedure Process_Aggregate (Proj : Project_Id); 3045 -- Recursive procedure to check the aggregated projects, as they may 3046 -- also be aggregated library projects. 3047 3048 ----------------------- 3049 -- Process_Aggregate -- 3050 ----------------------- 3051 3052 procedure Process_Aggregate (Proj : Project_Id) is 3053 Agg : Aggregated_Project_List; 3054 3055 begin 3056 Agg := Proj.Aggregated_Projects; 3057 while Agg /= null loop 3058 Error_Msg_Name_1 := Agg.Project.Name; 3059 3060 if Agg.Project.Qualifier /= Aggregate_Library 3061 and then Project.Library_ALI_Dir.Name = 3062 Agg.Project.Object_Directory.Name 3063 then 3064 Error_Msg 3065 (Data.Flags, 3066 "aggregate library 'A'L'I directory cannot be shared with" 3067 & " object directory of aggregated project %%", 3068 The_Lib_Kind.Location, Project); 3069 3070 elsif Project.Library_ALI_Dir.Name = 3071 Agg.Project.Library_Dir.Name 3072 then 3073 Error_Msg 3074 (Data.Flags, 3075 "aggregate library 'A'L'I directory cannot be shared with" 3076 & " library directory of aggregated project %%", 3077 The_Lib_Kind.Location, Project); 3078 3079 elsif Agg.Project.Qualifier /= Aggregate_Library 3080 and then Project.Library_Dir.Name = 3081 Agg.Project.Object_Directory.Name 3082 then 3083 Error_Msg 3084 (Data.Flags, 3085 "aggregate library directory cannot be shared with" 3086 & " object directory of aggregated project %%", 3087 The_Lib_Kind.Location, Project); 3088 3089 elsif Project.Library_Dir.Name = 3090 Agg.Project.Library_Dir.Name 3091 then 3092 Error_Msg 3093 (Data.Flags, 3094 "aggregate library directory cannot be shared with" 3095 & " library directory of aggregated project %%", 3096 The_Lib_Kind.Location, Project); 3097 end if; 3098 3099 if Agg.Project.Qualifier = Aggregate_Library then 3100 Process_Aggregate (Agg.Project); 3101 end if; 3102 3103 Agg := Agg.Next; 3104 end loop; 3105 end Process_Aggregate; 3106 3107 -- Start of processing for Check_Aggregate_Library_Dirs 3108 3109 begin 3110 if Project.Qualifier = Aggregate_Library then 3111 Process_Aggregate (Project); 3112 end if; 3113 end Check_Aggregate_Library_Dirs; 3114 3115 ------------------- 3116 -- Check_Library -- 3117 ------------------- 3118 3119 procedure Check_Library (Proj : Project_Id; Extends : Boolean) is 3120 Src_Id : Source_Id; 3121 Iter : Source_Iterator; 3122 3123 begin 3124 if Proj /= No_Project then 3125 if not Proj.Library then 3126 3127 -- The only not library projects that are OK are those that 3128 -- have no sources. However, header files from non-Ada 3129 -- languages are OK, as there is nothing to compile. 3130 3131 Iter := For_Each_Source (Data.Tree, Proj); 3132 loop 3133 Src_Id := Prj.Element (Iter); 3134 exit when Src_Id = No_Source 3135 or else Src_Id.Language.Config.Kind /= File_Based 3136 or else Src_Id.Kind /= Spec; 3137 Next (Iter); 3138 end loop; 3139 3140 if Src_Id /= No_Source then 3141 Error_Msg_Name_1 := Project.Name; 3142 Error_Msg_Name_2 := Proj.Name; 3143 3144 if Extends then 3145 if Project.Library_Kind /= Static then 3146 Error_Msg 3147 (Data.Flags, 3148 Continuation.all & 3149 "shared library project %% cannot extend " & 3150 "project %% that is not a library project", 3151 Project.Location, Project); 3152 Continuation := Continuation_String'Access; 3153 end if; 3154 3155 elsif not Unchecked_Shared_Lib_Imports 3156 and then Project.Library_Kind /= Static 3157 then 3158 Error_Msg 3159 (Data.Flags, 3160 Continuation.all & 3161 "shared library project %% cannot import project %% " & 3162 "that is not a shared library project", 3163 Project.Location, Project); 3164 Continuation := Continuation_String'Access; 3165 end if; 3166 end if; 3167 3168 elsif Project.Library_Kind /= Static 3169 and then not Lib_Standalone.Default 3170 and then Get_Name_String (Lib_Standalone.Value) = "encapsulated" 3171 and then Proj.Library_Kind /= Static 3172 then 3173 -- An encapsulated library must depend only on static libraries 3174 3175 Error_Msg_Name_1 := Project.Name; 3176 Error_Msg_Name_2 := Proj.Name; 3177 3178 Error_Msg 3179 (Data.Flags, 3180 Continuation.all & 3181 "encapsulated library project %% cannot import shared " & 3182 "library project %%", 3183 Project.Location, Project); 3184 Continuation := Continuation_String'Access; 3185 3186 elsif Project.Library_Kind /= Static 3187 and then Proj.Library_Kind = Static 3188 and then 3189 (Lib_Standalone.Default 3190 or else 3191 Get_Name_String (Lib_Standalone.Value) /= "encapsulated") 3192 then 3193 Error_Msg_Name_1 := Project.Name; 3194 Error_Msg_Name_2 := Proj.Name; 3195 3196 if Extends then 3197 Error_Msg 3198 (Data.Flags, 3199 Continuation.all & 3200 "shared library project %% cannot extend static " & 3201 "library project %%", 3202 Project.Location, Project); 3203 Continuation := Continuation_String'Access; 3204 3205 elsif not Unchecked_Shared_Lib_Imports then 3206 Error_Msg 3207 (Data.Flags, 3208 Continuation.all & 3209 "shared library project %% cannot import static " & 3210 "library project %%", 3211 Project.Location, Project); 3212 Continuation := Continuation_String'Access; 3213 end if; 3214 3215 end if; 3216 end if; 3217 end Check_Library; 3218 3219 Dir_Exists : Boolean; 3220 3221 -- Start of processing for Check_Library_Attributes 3222 3223 begin 3224 Library_Directory_Present := Lib_Dir.Value /= Empty_String; 3225 3226 -- Special case of extending project 3227 3228 if Project.Extends /= No_Project then 3229 3230 -- If the project extended is a library project, we inherit the 3231 -- library name, if it is not redefined; we check that the library 3232 -- directory is specified. 3233 3234 if Project.Extends.Library then 3235 if Project.Qualifier = Standard then 3236 Error_Msg 3237 (Data.Flags, 3238 "a standard project cannot extend a library project", 3239 Project.Location, Project); 3240 3241 else 3242 if Lib_Name.Default then 3243 Project.Library_Name := Project.Extends.Library_Name; 3244 end if; 3245 3246 if Lib_Dir.Default then 3247 if not Project.Virtual then 3248 Error_Msg 3249 (Data.Flags, 3250 "a project extending a library project must " & 3251 "specify an attribute Library_Dir", 3252 Project.Location, Project); 3253 3254 else 3255 -- For a virtual project extending a library project, 3256 -- inherit library directory and library kind. 3257 3258 Project.Library_Dir := Project.Extends.Library_Dir; 3259 Library_Directory_Present := True; 3260 Project.Library_Kind := Project.Extends.Library_Kind; 3261 end if; 3262 end if; 3263 end if; 3264 end if; 3265 end if; 3266 3267 pragma Assert (Lib_Name.Kind = Single); 3268 3269 if Lib_Name.Value = Empty_String then 3270 if Current_Verbosity = High 3271 and then Project.Library_Name = No_Name 3272 then 3273 Debug_Indent; 3274 Write_Line ("no library name"); 3275 end if; 3276 3277 else 3278 -- There is no restriction on the syntax of library names 3279 3280 Project.Library_Name := Lib_Name.Value; 3281 end if; 3282 3283 if Project.Library_Name /= No_Name then 3284 if Current_Verbosity = High then 3285 Write_Attr 3286 ("Library name: ", Get_Name_String (Project.Library_Name)); 3287 end if; 3288 3289 pragma Assert (Lib_Dir.Kind = Single); 3290 3291 if not Library_Directory_Present then 3292 Debug_Output ("no library directory"); 3293 3294 else 3295 -- Find path name (unless inherited), check that it is a directory 3296 3297 if Project.Library_Dir = No_Path_Information then 3298 Locate_Directory 3299 (Project, 3300 File_Name_Type (Lib_Dir.Value), 3301 Path => Project.Library_Dir, 3302 Dir_Exists => Dir_Exists, 3303 Data => Data, 3304 Create => "library", 3305 Must_Exist => False, 3306 Location => Lib_Dir.Location, 3307 Externally_Built => Project.Externally_Built); 3308 3309 else 3310 Dir_Exists := 3311 Is_Directory 3312 (Get_Name_String (Project.Library_Dir.Display_Name)); 3313 end if; 3314 3315 if not Dir_Exists then 3316 if Directories_Must_Exist_In_Projects then 3317 3318 -- Get the absolute name of the library directory that does 3319 -- not exist, to report an error. 3320 3321 Err_Vars.Error_Msg_File_1 := 3322 File_Name_Type (Project.Library_Dir.Display_Name); 3323 Error_Msg 3324 (Data.Flags, 3325 "library directory { does not exist", 3326 Lib_Dir.Location, Project); 3327 end if; 3328 3329 -- Checks for object/source directories 3330 3331 elsif not Project.Externally_Built 3332 3333 -- An aggregate library does not have sources or objects, so 3334 -- these tests are not required in this case. 3335 3336 and then Project.Qualifier /= Aggregate_Library 3337 then 3338 -- Library directory cannot be the same as Object directory 3339 3340 if Project.Library_Dir.Name = Project.Object_Directory.Name then 3341 Error_Msg 3342 (Data.Flags, 3343 "library directory cannot be the same " & 3344 "as object directory", 3345 Lib_Dir.Location, Project); 3346 Project.Library_Dir := No_Path_Information; 3347 3348 else 3349 declare 3350 OK : Boolean := True; 3351 Dirs_Id : String_List_Id; 3352 Dir_Elem : String_Element; 3353 Pid : Project_List; 3354 3355 begin 3356 -- The library directory cannot be the same as a source 3357 -- directory of the current project. 3358 3359 Dirs_Id := Project.Source_Dirs; 3360 while Dirs_Id /= Nil_String loop 3361 Dir_Elem := Shared.String_Elements.Table (Dirs_Id); 3362 Dirs_Id := Dir_Elem.Next; 3363 3364 if Project.Library_Dir.Name = 3365 Path_Name_Type (Dir_Elem.Value) 3366 then 3367 Err_Vars.Error_Msg_File_1 := 3368 File_Name_Type (Dir_Elem.Value); 3369 Error_Msg 3370 (Data.Flags, 3371 "library directory cannot be the same " 3372 & "as source directory {", 3373 Lib_Dir.Location, Project); 3374 OK := False; 3375 exit; 3376 end if; 3377 end loop; 3378 3379 if OK then 3380 3381 -- The library directory cannot be the same as a 3382 -- source directory of another project either. 3383 3384 Pid := Data.Tree.Projects; 3385 Project_Loop : loop 3386 exit Project_Loop when Pid = null; 3387 3388 if Pid.Project /= Project then 3389 Dirs_Id := Pid.Project.Source_Dirs; 3390 3391 Dir_Loop : while Dirs_Id /= Nil_String loop 3392 Dir_Elem := 3393 Shared.String_Elements.Table (Dirs_Id); 3394 Dirs_Id := Dir_Elem.Next; 3395 3396 if Project.Library_Dir.Name = 3397 Path_Name_Type (Dir_Elem.Value) 3398 then 3399 Err_Vars.Error_Msg_File_1 := 3400 File_Name_Type (Dir_Elem.Value); 3401 Err_Vars.Error_Msg_Name_1 := 3402 Pid.Project.Name; 3403 3404 Error_Msg 3405 (Data.Flags, 3406 "library directory cannot be the same " 3407 & "as source directory { of project %%", 3408 Lib_Dir.Location, Project); 3409 OK := False; 3410 exit Project_Loop; 3411 end if; 3412 end loop Dir_Loop; 3413 end if; 3414 3415 Pid := Pid.Next; 3416 end loop Project_Loop; 3417 end if; 3418 3419 if not OK then 3420 Project.Library_Dir := No_Path_Information; 3421 3422 elsif Current_Verbosity = High then 3423 3424 -- Display the Library directory in high verbosity 3425 3426 Write_Attr 3427 ("Library directory", 3428 Get_Name_String (Project.Library_Dir.Display_Name)); 3429 end if; 3430 end; 3431 end if; 3432 end if; 3433 end if; 3434 3435 end if; 3436 3437 Project.Library := 3438 Project.Library_Dir /= No_Path_Information 3439 and then Project.Library_Name /= No_Name; 3440 3441 if Project.Extends = No_Project then 3442 case Project.Qualifier is 3443 when Standard => 3444 if Project.Library then 3445 Error_Msg 3446 (Data.Flags, 3447 "a standard project cannot be a library project", 3448 Lib_Name.Location, Project); 3449 end if; 3450 3451 when Library | Aggregate_Library => 3452 if not Project.Library then 3453 if Project.Library_Name = No_Name then 3454 Error_Msg 3455 (Data.Flags, 3456 "attribute Library_Name not declared", 3457 Project.Location, Project); 3458 3459 if not Library_Directory_Present then 3460 Error_Msg 3461 (Data.Flags, 3462 "\attribute Library_Dir not declared", 3463 Project.Location, Project); 3464 end if; 3465 3466 elsif Project.Library_Dir = No_Path_Information then 3467 Error_Msg 3468 (Data.Flags, 3469 "attribute Library_Dir not declared", 3470 Project.Location, Project); 3471 end if; 3472 end if; 3473 3474 when others => 3475 null; 3476 end case; 3477 end if; 3478 3479 if Project.Library then 3480 Support_For_Libraries := Project.Config.Lib_Support; 3481 3482 if not Project.Externally_Built 3483 and then Support_For_Libraries = Prj.None 3484 then 3485 Error_Msg 3486 (Data.Flags, 3487 "?libraries are not supported on this platform", 3488 Lib_Name.Location, Project); 3489 Project.Library := False; 3490 3491 else 3492 if Lib_ALI_Dir.Value = Empty_String then 3493 Debug_Output ("no library ALI directory specified"); 3494 Project.Library_ALI_Dir := Project.Library_Dir; 3495 3496 else 3497 -- Find path name, check that it is a directory 3498 3499 Locate_Directory 3500 (Project, 3501 File_Name_Type (Lib_ALI_Dir.Value), 3502 Path => Project.Library_ALI_Dir, 3503 Create => "library ALI", 3504 Dir_Exists => Dir_Exists, 3505 Data => Data, 3506 Must_Exist => False, 3507 Location => Lib_ALI_Dir.Location, 3508 Externally_Built => Project.Externally_Built); 3509 3510 if not Dir_Exists then 3511 3512 -- Get the absolute name of the library ALI directory that 3513 -- does not exist, to report an error. 3514 3515 Err_Vars.Error_Msg_File_1 := 3516 File_Name_Type (Project.Library_ALI_Dir.Display_Name); 3517 Error_Msg 3518 (Data.Flags, 3519 "library 'A'L'I directory { does not exist", 3520 Lib_ALI_Dir.Location, Project); 3521 end if; 3522 3523 if not Project.Externally_Built 3524 and then Project.Library_ALI_Dir /= Project.Library_Dir 3525 then 3526 -- The library ALI directory cannot be the same as the 3527 -- Object directory. 3528 3529 if Project.Library_ALI_Dir = Project.Object_Directory then 3530 Error_Msg 3531 (Data.Flags, 3532 "library 'A'L'I directory cannot be the same " & 3533 "as object directory", 3534 Lib_ALI_Dir.Location, Project); 3535 Project.Library_ALI_Dir := No_Path_Information; 3536 3537 else 3538 declare 3539 OK : Boolean := True; 3540 Dirs_Id : String_List_Id; 3541 Dir_Elem : String_Element; 3542 Pid : Project_List; 3543 3544 begin 3545 -- The library ALI directory cannot be the same as 3546 -- a source directory of the current project. 3547 3548 Dirs_Id := Project.Source_Dirs; 3549 while Dirs_Id /= Nil_String loop 3550 Dir_Elem := Shared.String_Elements.Table (Dirs_Id); 3551 Dirs_Id := Dir_Elem.Next; 3552 3553 if Project.Library_ALI_Dir.Name = 3554 Path_Name_Type (Dir_Elem.Value) 3555 then 3556 Err_Vars.Error_Msg_File_1 := 3557 File_Name_Type (Dir_Elem.Value); 3558 Error_Msg 3559 (Data.Flags, 3560 "library 'A'L'I directory cannot be " & 3561 "the same as source directory {", 3562 Lib_ALI_Dir.Location, Project); 3563 OK := False; 3564 exit; 3565 end if; 3566 end loop; 3567 3568 if OK then 3569 3570 -- The library ALI directory cannot be the same as 3571 -- a source directory of another project either. 3572 3573 Pid := Data.Tree.Projects; 3574 ALI_Project_Loop : loop 3575 exit ALI_Project_Loop when Pid = null; 3576 3577 if Pid.Project /= Project then 3578 Dirs_Id := Pid.Project.Source_Dirs; 3579 3580 ALI_Dir_Loop : 3581 while Dirs_Id /= Nil_String loop 3582 Dir_Elem := 3583 Shared.String_Elements.Table (Dirs_Id); 3584 Dirs_Id := Dir_Elem.Next; 3585 3586 if Project.Library_ALI_Dir.Name = 3587 Path_Name_Type (Dir_Elem.Value) 3588 then 3589 Err_Vars.Error_Msg_File_1 := 3590 File_Name_Type (Dir_Elem.Value); 3591 Err_Vars.Error_Msg_Name_1 := 3592 Pid.Project.Name; 3593 3594 Error_Msg 3595 (Data.Flags, 3596 "library 'A'L'I directory cannot " & 3597 "be the same as source directory " & 3598 "{ of project %%", 3599 Lib_ALI_Dir.Location, Project); 3600 OK := False; 3601 exit ALI_Project_Loop; 3602 end if; 3603 end loop ALI_Dir_Loop; 3604 end if; 3605 Pid := Pid.Next; 3606 end loop ALI_Project_Loop; 3607 end if; 3608 3609 if not OK then 3610 Project.Library_ALI_Dir := No_Path_Information; 3611 3612 elsif Current_Verbosity = High then 3613 3614 -- Display Library ALI directory in high verbosity 3615 3616 Write_Attr 3617 ("Library ALI dir", 3618 Get_Name_String 3619 (Project.Library_ALI_Dir.Display_Name)); 3620 end if; 3621 end; 3622 end if; 3623 end if; 3624 end if; 3625 3626 pragma Assert (Lib_Version.Kind = Single); 3627 3628 if Lib_Version.Value = Empty_String then 3629 Debug_Output ("no library version specified"); 3630 3631 else 3632 Project.Lib_Internal_Name := Lib_Version.Value; 3633 end if; 3634 3635 pragma Assert (The_Lib_Kind.Kind = Single); 3636 3637 if The_Lib_Kind.Value = Empty_String then 3638 Debug_Output ("no library kind specified"); 3639 3640 else 3641 Get_Name_String (The_Lib_Kind.Value); 3642 3643 declare 3644 Kind_Name : constant String := 3645 To_Lower (Name_Buffer (1 .. Name_Len)); 3646 3647 OK : Boolean := True; 3648 3649 begin 3650 if Kind_Name = "static" then 3651 Project.Library_Kind := Static; 3652 3653 elsif Kind_Name = "dynamic" then 3654 Project.Library_Kind := Dynamic; 3655 3656 elsif Kind_Name = "relocatable" then 3657 Project.Library_Kind := Relocatable; 3658 3659 else 3660 Error_Msg 3661 (Data.Flags, 3662 "illegal value for Library_Kind", 3663 The_Lib_Kind.Location, Project); 3664 OK := False; 3665 end if; 3666 3667 if Current_Verbosity = High and then OK then 3668 Write_Attr ("Library kind", Kind_Name); 3669 end if; 3670 3671 if Project.Library_Kind /= Static then 3672 if not Project.Externally_Built 3673 and then Support_For_Libraries = Prj.Static_Only 3674 then 3675 Error_Msg 3676 (Data.Flags, 3677 "only static libraries are supported " & 3678 "on this platform", 3679 The_Lib_Kind.Location, Project); 3680 Project.Library := False; 3681 3682 else 3683 -- Check if (obsolescent) attribute Library_GCC or 3684 -- Linker'Driver is declared. 3685 3686 if Lib_GCC.Value /= Empty_String then 3687 Error_Msg 3688 (Data.Flags, 3689 "?Library_'G'C'C is an obsolescent attribute, " & 3690 "use Linker''Driver instead", 3691 Lib_GCC.Location, Project); 3692 Project.Config.Shared_Lib_Driver := 3693 File_Name_Type (Lib_GCC.Value); 3694 3695 else 3696 declare 3697 Linker : constant Package_Id := 3698 Value_Of 3699 (Name_Linker, 3700 Project.Decl.Packages, 3701 Shared); 3702 Driver : constant Variable_Value := 3703 Value_Of 3704 (Name => No_Name, 3705 Attribute_Or_Array_Name => 3706 Name_Driver, 3707 In_Package => Linker, 3708 Shared => Shared); 3709 3710 begin 3711 if Driver /= Nil_Variable_Value 3712 and then Driver.Value /= Empty_String 3713 then 3714 Project.Config.Shared_Lib_Driver := 3715 File_Name_Type (Driver.Value); 3716 end if; 3717 end; 3718 end if; 3719 end if; 3720 end if; 3721 end; 3722 end if; 3723 3724 if Project.Library 3725 and then Project.Qualifier /= Aggregate_Library 3726 then 3727 Debug_Output ("this is a library project file"); 3728 3729 Check_Library (Project.Extends, Extends => True); 3730 3731 Imported_Project_List := Project.Imported_Projects; 3732 while Imported_Project_List /= null loop 3733 Check_Library 3734 (Imported_Project_List.Project, 3735 Extends => False); 3736 Imported_Project_List := Imported_Project_List.Next; 3737 end loop; 3738 end if; 3739 end if; 3740 end if; 3741 3742 -- Check if Linker'Switches or Linker'Default_Switches are declared. 3743 -- Warn if they are declared, as it is a common error to think that 3744 -- library are "linked" with Linker switches. 3745 3746 if Project.Library then 3747 declare 3748 Linker_Package_Id : constant Package_Id := 3749 Util.Value_Of 3750 (Name_Linker, 3751 Project.Decl.Packages, Shared); 3752 Linker_Package : Package_Element; 3753 Switches : Array_Element_Id := No_Array_Element; 3754 3755 begin 3756 if Linker_Package_Id /= No_Package then 3757 Linker_Package := Shared.Packages.Table (Linker_Package_Id); 3758 3759 Switches := 3760 Value_Of 3761 (Name => Name_Switches, 3762 In_Arrays => Linker_Package.Decl.Arrays, 3763 Shared => Shared); 3764 3765 if Switches = No_Array_Element then 3766 Switches := 3767 Value_Of 3768 (Name => Name_Default_Switches, 3769 In_Arrays => Linker_Package.Decl.Arrays, 3770 Shared => Shared); 3771 end if; 3772 3773 if Switches /= No_Array_Element then 3774 Error_Msg 3775 (Data.Flags, 3776 "?\Linker switches not taken into account in library " & 3777 "projects", 3778 No_Location, Project); 3779 end if; 3780 end if; 3781 end; 3782 end if; 3783 3784 if Project.Extends /= No_Project and then Project.Extends.Library then 3785 3786 -- Remove the library name from Lib_Data_Table 3787 3788 for J in 1 .. Lib_Data_Table.Last loop 3789 if Lib_Data_Table.Table (J).Proj = Project.Extends then 3790 Lib_Data_Table.Table (J) := 3791 Lib_Data_Table.Table (Lib_Data_Table.Last); 3792 Lib_Data_Table.Set_Last (Lib_Data_Table.Last - 1); 3793 exit; 3794 end if; 3795 end loop; 3796 end if; 3797 3798 if Project.Library and then not Lib_Name.Default then 3799 3800 -- Check if the same library name is used in an other library project 3801 3802 for J in 1 .. Lib_Data_Table.Last loop 3803 if Lib_Data_Table.Table (J).Name = Project.Library_Name 3804 and then Lib_Data_Table.Table (J).Tree = Data.Tree 3805 then 3806 Error_Msg_Name_1 := Lib_Data_Table.Table (J).Proj.Name; 3807 Error_Msg 3808 (Data.Flags, 3809 "Library name cannot be the same as in project %%", 3810 Lib_Name.Location, Project); 3811 Project.Library := False; 3812 exit; 3813 end if; 3814 end loop; 3815 end if; 3816 3817 if not Lib_Standalone.Default 3818 and then Project.Library_Kind = Static 3819 then 3820 -- An standalone library must be a shared library 3821 3822 Error_Msg_Name_1 := Project.Name; 3823 3824 Error_Msg 3825 (Data.Flags, 3826 Continuation.all & 3827 "standalone library project %% must be a shared library", 3828 Project.Location, Project); 3829 Continuation := Continuation_String'Access; 3830 end if; 3831 3832 -- Check that aggregated libraries do not share the aggregate 3833 -- Library_ALI_Dir. 3834 3835 if Project.Qualifier = Aggregate_Library then 3836 Check_Aggregate_Library_Dirs; 3837 end if; 3838 3839 if Project.Library and not Data.In_Aggregate_Lib then 3840 3841 -- Record the library name 3842 3843 Lib_Data_Table.Append 3844 ((Name => Project.Library_Name, 3845 Proj => Project, 3846 Tree => Data.Tree)); 3847 end if; 3848 end Check_Library_Attributes; 3849 3850 -------------------------- 3851 -- Check_Package_Naming -- 3852 -------------------------- 3853 3854 procedure Check_Package_Naming 3855 (Project : Project_Id; 3856 Data : in out Tree_Processing_Data) 3857 is 3858 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; 3859 Naming_Id : constant Package_Id := 3860 Util.Value_Of 3861 (Name_Naming, Project.Decl.Packages, Shared); 3862 Naming : Package_Element; 3863 3864 Ada_Body_Suffix_Loc : Source_Ptr := No_Location; 3865 3866 procedure Check_Naming; 3867 -- Check the validity of the Naming package (suffixes valid, ...) 3868 3869 procedure Check_Common 3870 (Dot_Replacement : in out File_Name_Type; 3871 Casing : in out Casing_Type; 3872 Casing_Defined : out Boolean; 3873 Separate_Suffix : in out File_Name_Type; 3874 Sep_Suffix_Loc : out Source_Ptr); 3875 -- Check attributes common 3876 3877 procedure Process_Exceptions_File_Based 3878 (Lang_Id : Language_Ptr; 3879 Kind : Source_Kind); 3880 procedure Process_Exceptions_Unit_Based 3881 (Lang_Id : Language_Ptr; 3882 Kind : Source_Kind); 3883 -- Process the naming exceptions for the two types of languages 3884 3885 procedure Initialize_Naming_Data; 3886 -- Initialize internal naming data for the various languages 3887 3888 ------------------ 3889 -- Check_Common -- 3890 ------------------ 3891 3892 procedure Check_Common 3893 (Dot_Replacement : in out File_Name_Type; 3894 Casing : in out Casing_Type; 3895 Casing_Defined : out Boolean; 3896 Separate_Suffix : in out File_Name_Type; 3897 Sep_Suffix_Loc : out Source_Ptr) 3898 is 3899 Dot_Repl : constant Variable_Value := 3900 Util.Value_Of 3901 (Name_Dot_Replacement, 3902 Naming.Decl.Attributes, 3903 Shared); 3904 Casing_String : constant Variable_Value := 3905 Util.Value_Of 3906 (Name_Casing, 3907 Naming.Decl.Attributes, 3908 Shared); 3909 Sep_Suffix : constant Variable_Value := 3910 Util.Value_Of 3911 (Name_Separate_Suffix, 3912 Naming.Decl.Attributes, 3913 Shared); 3914 Dot_Repl_Loc : Source_Ptr; 3915 3916 begin 3917 Sep_Suffix_Loc := No_Location; 3918 3919 if not Dot_Repl.Default then 3920 pragma Assert 3921 (Dot_Repl.Kind = Single, "Dot_Replacement is not a string"); 3922 3923 if Length_Of_Name (Dot_Repl.Value) = 0 then 3924 Error_Msg 3925 (Data.Flags, "Dot_Replacement cannot be empty", 3926 Dot_Repl.Location, Project); 3927 end if; 3928 3929 Dot_Replacement := Canonical_Case_File_Name (Dot_Repl.Value); 3930 Dot_Repl_Loc := Dot_Repl.Location; 3931 3932 declare 3933 Repl : constant String := Get_Name_String (Dot_Replacement); 3934 3935 begin 3936 -- Dot_Replacement cannot 3937 -- - be empty 3938 -- - start or end with an alphanumeric 3939 -- - be a single '_' 3940 -- - start with an '_' followed by an alphanumeric 3941 -- - contain a '.' except if it is "." 3942 3943 if Repl'Length = 0 3944 or else Is_Alphanumeric (Repl (Repl'First)) 3945 or else Is_Alphanumeric (Repl (Repl'Last)) 3946 or else (Repl (Repl'First) = '_' 3947 and then 3948 (Repl'Length = 1 3949 or else 3950 Is_Alphanumeric (Repl (Repl'First + 1)))) 3951 or else (Repl'Length > 1 3952 and then 3953 Index (Source => Repl, Pattern => ".") /= 0) 3954 then 3955 Error_Msg 3956 (Data.Flags, 3957 '"' & Repl & 3958 """ is illegal for Dot_Replacement.", 3959 Dot_Repl_Loc, Project); 3960 end if; 3961 end; 3962 end if; 3963 3964 if Dot_Replacement /= No_File then 3965 Write_Attr 3966 ("Dot_Replacement", Get_Name_String (Dot_Replacement)); 3967 end if; 3968 3969 Casing_Defined := False; 3970 3971 if not Casing_String.Default then 3972 pragma Assert 3973 (Casing_String.Kind = Single, "Casing is not a string"); 3974 3975 declare 3976 Casing_Image : constant String := 3977 Get_Name_String (Casing_String.Value); 3978 3979 begin 3980 if Casing_Image'Length = 0 then 3981 Error_Msg 3982 (Data.Flags, 3983 "Casing cannot be an empty string", 3984 Casing_String.Location, Project); 3985 end if; 3986 3987 Casing := Value (Casing_Image); 3988 Casing_Defined := True; 3989 3990 exception 3991 when Constraint_Error => 3992 Name_Len := Casing_Image'Length; 3993 Name_Buffer (1 .. Name_Len) := Casing_Image; 3994 Err_Vars.Error_Msg_Name_1 := Name_Find; 3995 Error_Msg 3996 (Data.Flags, 3997 "%% is not a correct Casing", 3998 Casing_String.Location, Project); 3999 end; 4000 end if; 4001 4002 Write_Attr ("Casing", Image (Casing)); 4003 4004 if not Sep_Suffix.Default then 4005 if Length_Of_Name (Sep_Suffix.Value) = 0 then 4006 Error_Msg 4007 (Data.Flags, 4008 "Separate_Suffix cannot be empty", 4009 Sep_Suffix.Location, Project); 4010 4011 else 4012 Separate_Suffix := Canonical_Case_File_Name (Sep_Suffix.Value); 4013 Sep_Suffix_Loc := Sep_Suffix.Location; 4014 4015 Check_Illegal_Suffix 4016 (Project, Separate_Suffix, 4017 Dot_Replacement, "Separate_Suffix", Sep_Suffix.Location, 4018 Data); 4019 end if; 4020 end if; 4021 4022 if Separate_Suffix /= No_File then 4023 Write_Attr 4024 ("Separate_Suffix", Get_Name_String (Separate_Suffix)); 4025 end if; 4026 end Check_Common; 4027 4028 ----------------------------------- 4029 -- Process_Exceptions_File_Based -- 4030 ----------------------------------- 4031 4032 procedure Process_Exceptions_File_Based 4033 (Lang_Id : Language_Ptr; 4034 Kind : Source_Kind) 4035 is 4036 Lang : constant Name_Id := Lang_Id.Name; 4037 Exceptions : Array_Element_Id; 4038 Exception_List : Variable_Value; 4039 Element_Id : String_List_Id; 4040 Element : String_Element; 4041 File_Name : File_Name_Type; 4042 Source : Source_Id; 4043 4044 begin 4045 case Kind is 4046 when Impl | Sep => 4047 Exceptions := 4048 Value_Of 4049 (Name_Implementation_Exceptions, 4050 In_Arrays => Naming.Decl.Arrays, 4051 Shared => Shared); 4052 4053 when Spec => 4054 Exceptions := 4055 Value_Of 4056 (Name_Specification_Exceptions, 4057 In_Arrays => Naming.Decl.Arrays, 4058 Shared => Shared); 4059 end case; 4060 4061 Exception_List := 4062 Value_Of 4063 (Index => Lang, 4064 In_Array => Exceptions, 4065 Shared => Shared); 4066 4067 if Exception_List /= Nil_Variable_Value then 4068 Element_Id := Exception_List.Values; 4069 while Element_Id /= Nil_String loop 4070 Element := Shared.String_Elements.Table (Element_Id); 4071 File_Name := Canonical_Case_File_Name (Element.Value); 4072 4073 Source := 4074 Source_Files_Htable.Get 4075 (Data.Tree.Source_Files_HT, File_Name); 4076 while Source /= No_Source 4077 and then Source.Project /= Project 4078 loop 4079 Source := Source.Next_With_File_Name; 4080 end loop; 4081 4082 if Source = No_Source then 4083 Add_Source 4084 (Id => Source, 4085 Data => Data, 4086 Project => Project, 4087 Source_Dir_Rank => 0, 4088 Lang_Id => Lang_Id, 4089 Kind => Kind, 4090 File_Name => File_Name, 4091 Display_File => File_Name_Type (Element.Value), 4092 Naming_Exception => Yes, 4093 Location => Element.Location); 4094 4095 else 4096 -- Check if the file name is already recorded for another 4097 -- language or another kind. 4098 4099 if Source.Language /= Lang_Id then 4100 Error_Msg 4101 (Data.Flags, 4102 "the same file cannot be a source of two languages", 4103 Element.Location, Project); 4104 4105 elsif Source.Kind /= Kind then 4106 Error_Msg 4107 (Data.Flags, 4108 "the same file cannot be a source and a template", 4109 Element.Location, Project); 4110 end if; 4111 4112 -- If the file is already recorded for the same 4113 -- language and the same kind, it means that the file 4114 -- name appears several times in the *_Exceptions 4115 -- attribute; so there is nothing to do. 4116 end if; 4117 4118 Element_Id := Element.Next; 4119 end loop; 4120 end if; 4121 end Process_Exceptions_File_Based; 4122 4123 ----------------------------------- 4124 -- Process_Exceptions_Unit_Based -- 4125 ----------------------------------- 4126 4127 procedure Process_Exceptions_Unit_Based 4128 (Lang_Id : Language_Ptr; 4129 Kind : Source_Kind) 4130 is 4131 Exceptions : Array_Element_Id; 4132 Element : Array_Element; 4133 Unit : Name_Id; 4134 Index : Int; 4135 File_Name : File_Name_Type; 4136 Source : Source_Id; 4137 4138 Naming_Exception : Naming_Exception_Type; 4139 4140 begin 4141 case Kind is 4142 when Impl | Sep => 4143 Exceptions := 4144 Value_Of 4145 (Name_Body, 4146 In_Arrays => Naming.Decl.Arrays, 4147 Shared => Shared); 4148 4149 if Exceptions = No_Array_Element then 4150 Exceptions := 4151 Value_Of 4152 (Name_Implementation, 4153 In_Arrays => Naming.Decl.Arrays, 4154 Shared => Shared); 4155 end if; 4156 4157 when Spec => 4158 Exceptions := 4159 Value_Of 4160 (Name_Spec, 4161 In_Arrays => Naming.Decl.Arrays, 4162 Shared => Shared); 4163 4164 if Exceptions = No_Array_Element then 4165 Exceptions := 4166 Value_Of 4167 (Name_Specification, 4168 In_Arrays => Naming.Decl.Arrays, 4169 Shared => Shared); 4170 end if; 4171 end case; 4172 4173 while Exceptions /= No_Array_Element loop 4174 Element := Shared.Array_Elements.Table (Exceptions); 4175 4176 if Element.Restricted then 4177 Naming_Exception := Inherited; 4178 else 4179 Naming_Exception := Yes; 4180 end if; 4181 4182 File_Name := Canonical_Case_File_Name (Element.Value.Value); 4183 4184 Get_Name_String (Element.Index); 4185 To_Lower (Name_Buffer (1 .. Name_Len)); 4186 Index := Element.Value.Index; 4187 4188 -- Check if it is a valid unit name 4189 4190 Get_Name_String (Element.Index); 4191 Check_Unit_Name (Name_Buffer (1 .. Name_Len), Unit); 4192 4193 if Unit = No_Name then 4194 Err_Vars.Error_Msg_Name_1 := Element.Index; 4195 Error_Msg 4196 (Data.Flags, 4197 "%% is not a valid unit name.", 4198 Element.Value.Location, Project); 4199 end if; 4200 4201 if Unit /= No_Name then 4202 Add_Source 4203 (Id => Source, 4204 Data => Data, 4205 Project => Project, 4206 Source_Dir_Rank => 0, 4207 Lang_Id => Lang_Id, 4208 Kind => Kind, 4209 File_Name => File_Name, 4210 Display_File => File_Name_Type (Element.Value.Value), 4211 Unit => Unit, 4212 Index => Index, 4213 Location => Element.Value.Location, 4214 Naming_Exception => Naming_Exception); 4215 end if; 4216 4217 Exceptions := Element.Next; 4218 end loop; 4219 end Process_Exceptions_Unit_Based; 4220 4221 ------------------ 4222 -- Check_Naming -- 4223 ------------------ 4224 4225 procedure Check_Naming is 4226 Dot_Replacement : File_Name_Type := 4227 File_Name_Type 4228 (First_Name_Id + Character'Pos ('-')); 4229 Separate_Suffix : File_Name_Type := No_File; 4230 Casing : Casing_Type := All_Lower_Case; 4231 Casing_Defined : Boolean; 4232 Lang_Id : Language_Ptr; 4233 Sep_Suffix_Loc : Source_Ptr; 4234 Suffix : Variable_Value; 4235 Lang : Name_Id; 4236 4237 begin 4238 Check_Common 4239 (Dot_Replacement => Dot_Replacement, 4240 Casing => Casing, 4241 Casing_Defined => Casing_Defined, 4242 Separate_Suffix => Separate_Suffix, 4243 Sep_Suffix_Loc => Sep_Suffix_Loc); 4244 4245 -- For all unit based languages, if any, set the specified value 4246 -- of Dot_Replacement, Casing and/or Separate_Suffix. Do not 4247 -- systematically overwrite, since the defaults come from the 4248 -- configuration file. 4249 4250 if Dot_Replacement /= No_File 4251 or else Casing_Defined 4252 or else Separate_Suffix /= No_File 4253 then 4254 Lang_Id := Project.Languages; 4255 while Lang_Id /= No_Language_Index loop 4256 if Lang_Id.Config.Kind = Unit_Based then 4257 if Dot_Replacement /= No_File then 4258 Lang_Id.Config.Naming_Data.Dot_Replacement := 4259 Dot_Replacement; 4260 end if; 4261 4262 if Casing_Defined then 4263 Lang_Id.Config.Naming_Data.Casing := Casing; 4264 end if; 4265 end if; 4266 4267 Lang_Id := Lang_Id.Next; 4268 end loop; 4269 end if; 4270 4271 -- Next, get the spec and body suffixes 4272 4273 Lang_Id := Project.Languages; 4274 while Lang_Id /= No_Language_Index loop 4275 Lang := Lang_Id.Name; 4276 4277 -- Spec_Suffix 4278 4279 Suffix := Value_Of 4280 (Name => Lang, 4281 Attribute_Or_Array_Name => Name_Spec_Suffix, 4282 In_Package => Naming_Id, 4283 Shared => Shared); 4284 4285 if Suffix = Nil_Variable_Value then 4286 Suffix := Value_Of 4287 (Name => Lang, 4288 Attribute_Or_Array_Name => Name_Specification_Suffix, 4289 In_Package => Naming_Id, 4290 Shared => Shared); 4291 end if; 4292 4293 if Suffix /= Nil_Variable_Value 4294 and then Suffix.Value /= No_Name 4295 then 4296 Lang_Id.Config.Naming_Data.Spec_Suffix := 4297 File_Name_Type (Suffix.Value); 4298 4299 Check_Illegal_Suffix 4300 (Project, 4301 Lang_Id.Config.Naming_Data.Spec_Suffix, 4302 Lang_Id.Config.Naming_Data.Dot_Replacement, 4303 "Spec_Suffix", Suffix.Location, Data); 4304 4305 Write_Attr 4306 ("Spec_Suffix", 4307 Get_Name_String (Lang_Id.Config.Naming_Data.Spec_Suffix)); 4308 end if; 4309 4310 -- Body_Suffix 4311 4312 Suffix := 4313 Value_Of 4314 (Name => Lang, 4315 Attribute_Or_Array_Name => Name_Body_Suffix, 4316 In_Package => Naming_Id, 4317 Shared => Shared); 4318 4319 if Suffix = Nil_Variable_Value then 4320 Suffix := 4321 Value_Of 4322 (Name => Lang, 4323 Attribute_Or_Array_Name => Name_Implementation_Suffix, 4324 In_Package => Naming_Id, 4325 Shared => Shared); 4326 end if; 4327 4328 if Suffix /= Nil_Variable_Value 4329 and then Suffix.Value /= No_Name 4330 then 4331 Lang_Id.Config.Naming_Data.Body_Suffix := 4332 File_Name_Type (Suffix.Value); 4333 4334 -- The default value of separate suffix should be the same as 4335 -- the body suffix, so we need to compute that first. 4336 4337 if Separate_Suffix = No_File then 4338 Lang_Id.Config.Naming_Data.Separate_Suffix := 4339 Lang_Id.Config.Naming_Data.Body_Suffix; 4340 Write_Attr 4341 ("Sep_Suffix", 4342 Get_Name_String 4343 (Lang_Id.Config.Naming_Data.Separate_Suffix)); 4344 else 4345 Lang_Id.Config.Naming_Data.Separate_Suffix := 4346 Separate_Suffix; 4347 end if; 4348 4349 Check_Illegal_Suffix 4350 (Project, 4351 Lang_Id.Config.Naming_Data.Body_Suffix, 4352 Lang_Id.Config.Naming_Data.Dot_Replacement, 4353 "Body_Suffix", Suffix.Location, Data); 4354 4355 Write_Attr 4356 ("Body_Suffix", 4357 Get_Name_String (Lang_Id.Config.Naming_Data.Body_Suffix)); 4358 4359 elsif Separate_Suffix /= No_File then 4360 Lang_Id.Config.Naming_Data.Separate_Suffix := Separate_Suffix; 4361 end if; 4362 4363 -- Spec_Suffix cannot be equal to Body_Suffix or Separate_Suffix, 4364 -- since that would cause a clear ambiguity. Note that we do allow 4365 -- a Spec_Suffix to have the same termination as one of these, 4366 -- which causes a potential ambiguity, but we resolve that by 4367 -- matching the longest possible suffix. 4368 4369 if Lang_Id.Config.Naming_Data.Spec_Suffix /= No_File 4370 and then Lang_Id.Config.Naming_Data.Spec_Suffix = 4371 Lang_Id.Config.Naming_Data.Body_Suffix 4372 then 4373 Error_Msg 4374 (Data.Flags, 4375 "Body_Suffix (""" 4376 & Get_Name_String (Lang_Id.Config.Naming_Data.Body_Suffix) 4377 & """) cannot be the same as Spec_Suffix.", 4378 Ada_Body_Suffix_Loc, Project); 4379 end if; 4380 4381 if Lang_Id.Config.Naming_Data.Body_Suffix /= 4382 Lang_Id.Config.Naming_Data.Separate_Suffix 4383 and then Lang_Id.Config.Naming_Data.Spec_Suffix = 4384 Lang_Id.Config.Naming_Data.Separate_Suffix 4385 then 4386 Error_Msg 4387 (Data.Flags, 4388 "Separate_Suffix (""" 4389 & Get_Name_String 4390 (Lang_Id.Config.Naming_Data.Separate_Suffix) 4391 & """) cannot be the same as Spec_Suffix.", 4392 Sep_Suffix_Loc, Project); 4393 end if; 4394 4395 Lang_Id := Lang_Id.Next; 4396 end loop; 4397 4398 -- Get the naming exceptions for all languages, but not for virtual 4399 -- projects. 4400 4401 if not Project.Virtual then 4402 for Kind in Spec_Or_Body loop 4403 Lang_Id := Project.Languages; 4404 while Lang_Id /= No_Language_Index loop 4405 case Lang_Id.Config.Kind is 4406 when File_Based => 4407 Process_Exceptions_File_Based (Lang_Id, Kind); 4408 4409 when Unit_Based => 4410 Process_Exceptions_Unit_Based (Lang_Id, Kind); 4411 end case; 4412 4413 Lang_Id := Lang_Id.Next; 4414 end loop; 4415 end loop; 4416 end if; 4417 end Check_Naming; 4418 4419 ---------------------------- 4420 -- Initialize_Naming_Data -- 4421 ---------------------------- 4422 4423 procedure Initialize_Naming_Data is 4424 Specs : Array_Element_Id := 4425 Util.Value_Of 4426 (Name_Spec_Suffix, 4427 Naming.Decl.Arrays, 4428 Shared); 4429 4430 Impls : Array_Element_Id := 4431 Util.Value_Of 4432 (Name_Body_Suffix, 4433 Naming.Decl.Arrays, 4434 Shared); 4435 4436 Lang : Language_Ptr; 4437 Lang_Name : Name_Id; 4438 Value : Variable_Value; 4439 Extended : Project_Id; 4440 4441 begin 4442 -- At this stage, the project already contains the default extensions 4443 -- for the various languages. We now merge those suffixes read in the 4444 -- user project, and they override the default. 4445 4446 while Specs /= No_Array_Element loop 4447 Lang_Name := Shared.Array_Elements.Table (Specs).Index; 4448 Lang := 4449 Get_Language_From_Name 4450 (Project, Name => Get_Name_String (Lang_Name)); 4451 4452 -- An extending project inherits its parent projects' languages 4453 -- so if needed we should create entries for those languages 4454 4455 if Lang = null then 4456 Extended := Project.Extends; 4457 while Extended /= null loop 4458 Lang := Get_Language_From_Name 4459 (Extended, Name => Get_Name_String (Lang_Name)); 4460 exit when Lang /= null; 4461 4462 Extended := Extended.Extends; 4463 end loop; 4464 4465 if Lang /= null then 4466 Lang := new Language_Data'(Lang.all); 4467 Lang.First_Source := null; 4468 Lang.Next := Project.Languages; 4469 Project.Languages := Lang; 4470 end if; 4471 end if; 4472 4473 -- If language was not found in project or the projects it extends 4474 4475 if Lang = null then 4476 Debug_Output 4477 ("ignoring spec naming data (lang. not in project): ", 4478 Lang_Name); 4479 4480 else 4481 Value := Shared.Array_Elements.Table (Specs).Value; 4482 4483 if Value.Kind = Single then 4484 Lang.Config.Naming_Data.Spec_Suffix := 4485 Canonical_Case_File_Name (Value.Value); 4486 end if; 4487 end if; 4488 4489 Specs := Shared.Array_Elements.Table (Specs).Next; 4490 end loop; 4491 4492 while Impls /= No_Array_Element loop 4493 Lang_Name := Shared.Array_Elements.Table (Impls).Index; 4494 Lang := 4495 Get_Language_From_Name 4496 (Project, Name => Get_Name_String (Lang_Name)); 4497 4498 if Lang = null then 4499 Debug_Output 4500 ("ignoring impl naming data (lang. not in project): ", 4501 Lang_Name); 4502 else 4503 Value := Shared.Array_Elements.Table (Impls).Value; 4504 4505 if Lang.Name = Name_Ada then 4506 Ada_Body_Suffix_Loc := Value.Location; 4507 end if; 4508 4509 if Value.Kind = Single then 4510 Lang.Config.Naming_Data.Body_Suffix := 4511 Canonical_Case_File_Name (Value.Value); 4512 end if; 4513 end if; 4514 4515 Impls := Shared.Array_Elements.Table (Impls).Next; 4516 end loop; 4517 end Initialize_Naming_Data; 4518 4519 -- Start of processing for Check_Naming_Schemes 4520 4521 begin 4522 -- No Naming package or parsing a configuration file? nothing to do 4523 4524 if Naming_Id /= No_Package 4525 and then Project.Qualifier /= Configuration 4526 then 4527 Naming := Shared.Packages.Table (Naming_Id); 4528 Debug_Increase_Indent ("checking package Naming for ", Project.Name); 4529 Initialize_Naming_Data; 4530 Check_Naming; 4531 Debug_Decrease_Indent ("done checking package naming"); 4532 end if; 4533 end Check_Package_Naming; 4534 4535 --------------------------------- 4536 -- Check_Programming_Languages -- 4537 --------------------------------- 4538 4539 procedure Check_Programming_Languages 4540 (Project : Project_Id; 4541 Data : in out Tree_Processing_Data) 4542 is 4543 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; 4544 4545 Languages : Variable_Value := Nil_Variable_Value; 4546 Def_Lang : Variable_Value := Nil_Variable_Value; 4547 Def_Lang_Id : Name_Id; 4548 4549 procedure Add_Language (Name, Display_Name : Name_Id); 4550 -- Add a new language to the list of languages for the project. 4551 -- Nothing is done if the language has already been defined 4552 4553 ------------------ 4554 -- Add_Language -- 4555 ------------------ 4556 4557 procedure Add_Language (Name, Display_Name : Name_Id) is 4558 Lang : Language_Ptr; 4559 4560 begin 4561 Lang := Project.Languages; 4562 while Lang /= No_Language_Index loop 4563 if Name = Lang.Name then 4564 return; 4565 end if; 4566 4567 Lang := Lang.Next; 4568 end loop; 4569 4570 Lang := new Language_Data'(No_Language_Data); 4571 Lang.Next := Project.Languages; 4572 Project.Languages := Lang; 4573 Lang.Name := Name; 4574 Lang.Display_Name := Display_Name; 4575 end Add_Language; 4576 4577 -- Start of processing for Check_Programming_Languages 4578 4579 begin 4580 Project.Languages := null; 4581 Languages := 4582 Prj.Util.Value_Of (Name_Languages, Project.Decl.Attributes, Shared); 4583 Def_Lang := 4584 Prj.Util.Value_Of 4585 (Name_Default_Language, Project.Decl.Attributes, Shared); 4586 4587 if Project.Source_Dirs /= Nil_String then 4588 4589 -- Check if languages are specified in this project 4590 4591 if Languages.Default then 4592 4593 -- Fail if there is no default language defined 4594 4595 if Def_Lang.Default then 4596 Error_Msg 4597 (Data.Flags, 4598 "no languages defined for this project", 4599 Project.Location, Project); 4600 Def_Lang_Id := No_Name; 4601 4602 else 4603 Get_Name_String (Def_Lang.Value); 4604 To_Lower (Name_Buffer (1 .. Name_Len)); 4605 Def_Lang_Id := Name_Find; 4606 end if; 4607 4608 if Def_Lang_Id /= No_Name then 4609 Get_Name_String (Def_Lang_Id); 4610 Name_Buffer (1) := GNAT.Case_Util.To_Upper (Name_Buffer (1)); 4611 Add_Language 4612 (Name => Def_Lang_Id, 4613 Display_Name => Name_Find); 4614 end if; 4615 4616 else 4617 declare 4618 Current : String_List_Id := Languages.Values; 4619 Element : String_Element; 4620 4621 begin 4622 -- If there are no languages declared, there are no sources 4623 4624 if Current = Nil_String then 4625 Project.Source_Dirs := Nil_String; 4626 4627 if Project.Qualifier = Standard then 4628 Error_Msg 4629 (Data.Flags, 4630 "a standard project must have at least one language", 4631 Languages.Location, Project); 4632 end if; 4633 4634 else 4635 -- Look through all the languages specified in attribute 4636 -- Languages. 4637 4638 while Current /= Nil_String loop 4639 Element := Shared.String_Elements.Table (Current); 4640 Get_Name_String (Element.Value); 4641 To_Lower (Name_Buffer (1 .. Name_Len)); 4642 4643 Add_Language 4644 (Name => Name_Find, 4645 Display_Name => Element.Value); 4646 4647 Current := Element.Next; 4648 end loop; 4649 end if; 4650 end; 4651 end if; 4652 end if; 4653 end Check_Programming_Languages; 4654 4655 ------------------------------- 4656 -- Check_Stand_Alone_Library -- 4657 ------------------------------- 4658 4659 procedure Check_Stand_Alone_Library 4660 (Project : Project_Id; 4661 Data : in out Tree_Processing_Data) 4662 is 4663 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; 4664 4665 Lib_Name : constant Prj.Variable_Value := 4666 Prj.Util.Value_Of 4667 (Snames.Name_Library_Name, 4668 Project.Decl.Attributes, 4669 Shared); 4670 4671 Lib_Standalone : constant Prj.Variable_Value := 4672 Prj.Util.Value_Of 4673 (Snames.Name_Library_Standalone, 4674 Project.Decl.Attributes, 4675 Shared); 4676 4677 Lib_Auto_Init : constant Prj.Variable_Value := 4678 Prj.Util.Value_Of 4679 (Snames.Name_Library_Auto_Init, 4680 Project.Decl.Attributes, 4681 Shared); 4682 4683 Lib_Src_Dir : constant Prj.Variable_Value := 4684 Prj.Util.Value_Of 4685 (Snames.Name_Library_Src_Dir, 4686 Project.Decl.Attributes, 4687 Shared); 4688 4689 Lib_Symbol_File : constant Prj.Variable_Value := 4690 Prj.Util.Value_Of 4691 (Snames.Name_Library_Symbol_File, 4692 Project.Decl.Attributes, 4693 Shared); 4694 4695 Lib_Symbol_Policy : constant Prj.Variable_Value := 4696 Prj.Util.Value_Of 4697 (Snames.Name_Library_Symbol_Policy, 4698 Project.Decl.Attributes, 4699 Shared); 4700 4701 Lib_Ref_Symbol_File : constant Prj.Variable_Value := 4702 Prj.Util.Value_Of 4703 (Snames.Name_Library_Reference_Symbol_File, 4704 Project.Decl.Attributes, 4705 Shared); 4706 4707 Auto_Init_Supported : Boolean; 4708 OK : Boolean := True; 4709 4710 begin 4711 Auto_Init_Supported := Project.Config.Auto_Init_Supported; 4712 4713 -- It is a stand-alone library project file if there is at least one 4714 -- unit in the declared or inherited interface. 4715 4716 if Project.Lib_Interface_ALIs = Nil_String then 4717 if not Lib_Standalone.Default 4718 and then Get_Name_String (Lib_Standalone.Value) /= "no" 4719 then 4720 Error_Msg 4721 (Data.Flags, 4722 "Library_Standalone valid only if library has Ada interfaces", 4723 Lib_Standalone.Location, Project); 4724 end if; 4725 4726 else 4727 if Project.Standalone_Library = No then 4728 Project.Standalone_Library := Standard; 4729 end if; 4730 4731 -- The name of a stand-alone library needs to have the syntax of an 4732 -- Ada identifier. 4733 4734 declare 4735 Name : constant String := Get_Name_String (Project.Library_Name); 4736 OK : Boolean := Is_Letter (Name (Name'First)); 4737 4738 Underline : Boolean := False; 4739 4740 begin 4741 for J in Name'First + 1 .. Name'Last loop 4742 exit when not OK; 4743 4744 if Is_Alphanumeric (Name (J)) then 4745 Underline := False; 4746 4747 elsif Name (J) = '_' then 4748 if Underline then 4749 OK := False; 4750 else 4751 Underline := True; 4752 end if; 4753 4754 else 4755 OK := False; 4756 end if; 4757 end loop; 4758 4759 OK := OK and not Underline; 4760 4761 if not OK then 4762 Error_Msg 4763 (Data.Flags, 4764 "Incorrect library name for a Stand-Alone Library", 4765 Lib_Name.Location, Project); 4766 return; 4767 end if; 4768 end; 4769 4770 if Lib_Standalone.Default then 4771 Project.Standalone_Library := Standard; 4772 4773 else 4774 Get_Name_String (Lib_Standalone.Value); 4775 To_Lower (Name_Buffer (1 .. Name_Len)); 4776 4777 if Name_Buffer (1 .. Name_Len) = "standard" then 4778 Project.Standalone_Library := Standard; 4779 4780 elsif Name_Buffer (1 .. Name_Len) = "encapsulated" then 4781 Project.Standalone_Library := Encapsulated; 4782 4783 elsif Name_Buffer (1 .. Name_Len) = "no" then 4784 Project.Standalone_Library := No; 4785 Error_Msg 4786 (Data.Flags, 4787 "wrong value for Library_Standalone " 4788 & "when Library_Interface defined", 4789 Lib_Standalone.Location, Project); 4790 4791 else 4792 Error_Msg 4793 (Data.Flags, 4794 "invalid value for attribute Library_Standalone", 4795 Lib_Standalone.Location, Project); 4796 end if; 4797 end if; 4798 4799 -- Check value of attribute Library_Auto_Init and set Lib_Auto_Init 4800 -- accordingly. 4801 4802 if Lib_Auto_Init.Default then 4803 4804 -- If no attribute Library_Auto_Init is declared, then set auto 4805 -- init only if it is supported. 4806 4807 Project.Lib_Auto_Init := Auto_Init_Supported; 4808 4809 else 4810 Get_Name_String (Lib_Auto_Init.Value); 4811 To_Lower (Name_Buffer (1 .. Name_Len)); 4812 4813 if Name_Buffer (1 .. Name_Len) = "false" then 4814 Project.Lib_Auto_Init := False; 4815 4816 elsif Name_Buffer (1 .. Name_Len) = "true" then 4817 if Auto_Init_Supported then 4818 Project.Lib_Auto_Init := True; 4819 4820 else 4821 -- Library_Auto_Init cannot be "true" if auto init is not 4822 -- supported. 4823 4824 Error_Msg 4825 (Data.Flags, 4826 "library auto init not supported " & 4827 "on this platform", 4828 Lib_Auto_Init.Location, Project); 4829 end if; 4830 4831 else 4832 Error_Msg 4833 (Data.Flags, 4834 "invalid value for attribute Library_Auto_Init", 4835 Lib_Auto_Init.Location, Project); 4836 end if; 4837 end if; 4838 4839 -- If attribute Library_Src_Dir is defined and not the empty string, 4840 -- check if the directory exist and is not the object directory or 4841 -- one of the source directories. This is the directory where copies 4842 -- of the interface sources will be copied. Note that this directory 4843 -- may be the library directory. 4844 4845 if Lib_Src_Dir.Value /= Empty_String then 4846 declare 4847 Dir_Id : constant File_Name_Type := 4848 File_Name_Type (Lib_Src_Dir.Value); 4849 Dir_Exists : Boolean; 4850 4851 begin 4852 Locate_Directory 4853 (Project, 4854 Dir_Id, 4855 Path => Project.Library_Src_Dir, 4856 Dir_Exists => Dir_Exists, 4857 Data => Data, 4858 Must_Exist => False, 4859 Create => "library source copy", 4860 Location => Lib_Src_Dir.Location, 4861 Externally_Built => Project.Externally_Built); 4862 4863 -- If directory does not exist, report an error 4864 4865 if not Dir_Exists then 4866 4867 -- Get the absolute name of the library directory that does 4868 -- not exist, to report an error. 4869 4870 Err_Vars.Error_Msg_File_1 := 4871 File_Name_Type (Project.Library_Src_Dir.Display_Name); 4872 Error_Msg 4873 (Data.Flags, 4874 "Directory { does not exist", 4875 Lib_Src_Dir.Location, Project); 4876 4877 -- Report error if it is the same as the object directory 4878 4879 elsif Project.Library_Src_Dir = Project.Object_Directory then 4880 Error_Msg 4881 (Data.Flags, 4882 "directory to copy interfaces cannot be " & 4883 "the object directory", 4884 Lib_Src_Dir.Location, Project); 4885 Project.Library_Src_Dir := No_Path_Information; 4886 4887 else 4888 declare 4889 Src_Dirs : String_List_Id; 4890 Src_Dir : String_Element; 4891 Pid : Project_List; 4892 4893 begin 4894 -- Interface copy directory cannot be one of the source 4895 -- directory of the current project. 4896 4897 Src_Dirs := Project.Source_Dirs; 4898 while Src_Dirs /= Nil_String loop 4899 Src_Dir := Shared.String_Elements.Table (Src_Dirs); 4900 4901 -- Report error if it is one of the source directories 4902 4903 if Project.Library_Src_Dir.Name = 4904 Path_Name_Type (Src_Dir.Value) 4905 then 4906 Error_Msg 4907 (Data.Flags, 4908 "directory to copy interfaces cannot " & 4909 "be one of the source directories", 4910 Lib_Src_Dir.Location, Project); 4911 Project.Library_Src_Dir := No_Path_Information; 4912 exit; 4913 end if; 4914 4915 Src_Dirs := Src_Dir.Next; 4916 end loop; 4917 4918 if Project.Library_Src_Dir /= No_Path_Information then 4919 4920 -- It cannot be a source directory of any other 4921 -- project either. 4922 4923 Pid := Data.Tree.Projects; 4924 Project_Loop : loop 4925 exit Project_Loop when Pid = null; 4926 4927 Src_Dirs := Pid.Project.Source_Dirs; 4928 Dir_Loop : while Src_Dirs /= Nil_String loop 4929 Src_Dir := 4930 Shared.String_Elements.Table (Src_Dirs); 4931 4932 -- Report error if it is one of the source 4933 -- directories. 4934 4935 if Project.Library_Src_Dir.Name = 4936 Path_Name_Type (Src_Dir.Value) 4937 then 4938 Error_Msg_File_1 := 4939 File_Name_Type (Src_Dir.Value); 4940 Error_Msg_Name_1 := Pid.Project.Name; 4941 Error_Msg 4942 (Data.Flags, 4943 "directory to copy interfaces cannot " & 4944 "be the same as source directory { of " & 4945 "project %%", 4946 Lib_Src_Dir.Location, Project); 4947 Project.Library_Src_Dir := 4948 No_Path_Information; 4949 exit Project_Loop; 4950 end if; 4951 4952 Src_Dirs := Src_Dir.Next; 4953 end loop Dir_Loop; 4954 4955 Pid := Pid.Next; 4956 end loop Project_Loop; 4957 end if; 4958 end; 4959 4960 -- In high verbosity, if there is a valid Library_Src_Dir, 4961 -- display its path name. 4962 4963 if Project.Library_Src_Dir /= No_Path_Information 4964 and then Current_Verbosity = High 4965 then 4966 Write_Attr 4967 ("Directory to copy interfaces", 4968 Get_Name_String (Project.Library_Src_Dir.Name)); 4969 end if; 4970 end if; 4971 end; 4972 end if; 4973 4974 -- Check the symbol related attributes 4975 4976 -- First, the symbol policy 4977 4978 if not Lib_Symbol_Policy.Default then 4979 declare 4980 Value : constant String := 4981 To_Lower 4982 (Get_Name_String (Lib_Symbol_Policy.Value)); 4983 4984 begin 4985 -- Symbol policy must have one of a limited number of values 4986 4987 if Value = "autonomous" or else Value = "default" then 4988 Project.Symbol_Data.Symbol_Policy := Autonomous; 4989 4990 elsif Value = "compliant" then 4991 Project.Symbol_Data.Symbol_Policy := Compliant; 4992 4993 elsif Value = "controlled" then 4994 Project.Symbol_Data.Symbol_Policy := Controlled; 4995 4996 elsif Value = "restricted" then 4997 Project.Symbol_Data.Symbol_Policy := Restricted; 4998 4999 elsif Value = "direct" then 5000 Project.Symbol_Data.Symbol_Policy := Direct; 5001 5002 else 5003 Error_Msg 5004 (Data.Flags, 5005 "illegal value for Library_Symbol_Policy", 5006 Lib_Symbol_Policy.Location, Project); 5007 end if; 5008 end; 5009 end if; 5010 5011 -- If attribute Library_Symbol_File is not specified, symbol policy 5012 -- cannot be Restricted. 5013 5014 if Lib_Symbol_File.Default then 5015 if Project.Symbol_Data.Symbol_Policy = Restricted then 5016 Error_Msg 5017 (Data.Flags, 5018 "Library_Symbol_File needs to be defined when " & 5019 "symbol policy is Restricted", 5020 Lib_Symbol_Policy.Location, Project); 5021 end if; 5022 5023 else 5024 -- Library_Symbol_File is defined 5025 5026 Project.Symbol_Data.Symbol_File := 5027 Path_Name_Type (Lib_Symbol_File.Value); 5028 5029 Get_Name_String (Lib_Symbol_File.Value); 5030 5031 if Name_Len = 0 then 5032 Error_Msg 5033 (Data.Flags, 5034 "symbol file name cannot be an empty string", 5035 Lib_Symbol_File.Location, Project); 5036 5037 else 5038 OK := not Is_Absolute_Path (Name_Buffer (1 .. Name_Len)); 5039 5040 if OK then 5041 for J in 1 .. Name_Len loop 5042 if Is_Directory_Separator (Name_Buffer (J)) then 5043 OK := False; 5044 exit; 5045 end if; 5046 end loop; 5047 end if; 5048 5049 if not OK then 5050 Error_Msg_File_1 := File_Name_Type (Lib_Symbol_File.Value); 5051 Error_Msg 5052 (Data.Flags, 5053 "symbol file name { is illegal. " & 5054 "Name cannot include directory info.", 5055 Lib_Symbol_File.Location, Project); 5056 end if; 5057 end if; 5058 end if; 5059 5060 -- If attribute Library_Reference_Symbol_File is not defined, 5061 -- symbol policy cannot be Compliant or Controlled. 5062 5063 if Lib_Ref_Symbol_File.Default then 5064 if Project.Symbol_Data.Symbol_Policy = Compliant 5065 or else Project.Symbol_Data.Symbol_Policy = Controlled 5066 then 5067 Error_Msg 5068 (Data.Flags, 5069 "a reference symbol file needs to be defined", 5070 Lib_Symbol_Policy.Location, Project); 5071 end if; 5072 5073 else 5074 -- Library_Reference_Symbol_File is defined, check file exists 5075 5076 Project.Symbol_Data.Reference := 5077 Path_Name_Type (Lib_Ref_Symbol_File.Value); 5078 5079 Get_Name_String (Lib_Ref_Symbol_File.Value); 5080 5081 if Name_Len = 0 then 5082 Error_Msg 5083 (Data.Flags, 5084 "reference symbol file name cannot be an empty string", 5085 Lib_Symbol_File.Location, Project); 5086 5087 else 5088 if not Is_Absolute_Path (Name_Buffer (1 .. Name_Len)) then 5089 Name_Len := 0; 5090 Add_Str_To_Name_Buffer 5091 (Get_Name_String (Project.Directory.Name)); 5092 Add_Str_To_Name_Buffer 5093 (Get_Name_String (Lib_Ref_Symbol_File.Value)); 5094 Project.Symbol_Data.Reference := Name_Find; 5095 end if; 5096 5097 if not Is_Regular_File 5098 (Get_Name_String (Project.Symbol_Data.Reference)) 5099 then 5100 Error_Msg_File_1 := 5101 File_Name_Type (Lib_Ref_Symbol_File.Value); 5102 5103 -- For controlled and direct symbol policies, it is an error 5104 -- if the reference symbol file does not exist. For other 5105 -- symbol policies, this is just a warning 5106 5107 Error_Msg_Warn := 5108 Project.Symbol_Data.Symbol_Policy /= Controlled 5109 and then Project.Symbol_Data.Symbol_Policy /= Direct; 5110 5111 Error_Msg 5112 (Data.Flags, 5113 "<library reference symbol file { does not exist", 5114 Lib_Ref_Symbol_File.Location, Project); 5115 5116 -- In addition in the non-controlled case, if symbol policy 5117 -- is Compliant, it is changed to Autonomous, because there 5118 -- is no reference to check against, and we don't want to 5119 -- fail in this case. 5120 5121 if Project.Symbol_Data.Symbol_Policy /= Controlled then 5122 if Project.Symbol_Data.Symbol_Policy = Compliant then 5123 Project.Symbol_Data.Symbol_Policy := Autonomous; 5124 end if; 5125 end if; 5126 end if; 5127 5128 -- If both the reference symbol file and the symbol file are 5129 -- defined, then check that they are not the same file. 5130 5131 if Project.Symbol_Data.Symbol_File /= No_Path then 5132 Get_Name_String (Project.Symbol_Data.Symbol_File); 5133 5134 if Name_Len > 0 then 5135 declare 5136 -- We do not need to pass a Directory to 5137 -- Normalize_Pathname, since the path_information 5138 -- already contains absolute information. 5139 5140 Symb_Path : constant String := 5141 Normalize_Pathname 5142 (Get_Name_String 5143 (Project.Object_Directory.Name) & 5144 Name_Buffer (1 .. Name_Len), 5145 Directory => "/", 5146 Resolve_Links => 5147 Opt.Follow_Links_For_Files); 5148 Ref_Path : constant String := 5149 Normalize_Pathname 5150 (Get_Name_String 5151 (Project.Symbol_Data.Reference), 5152 Directory => "/", 5153 Resolve_Links => 5154 Opt.Follow_Links_For_Files); 5155 begin 5156 if Symb_Path = Ref_Path then 5157 Error_Msg 5158 (Data.Flags, 5159 "library reference symbol file and library" & 5160 " symbol file cannot be the same file", 5161 Lib_Ref_Symbol_File.Location, Project); 5162 end if; 5163 end; 5164 end if; 5165 end if; 5166 end if; 5167 end if; 5168 end if; 5169 end Check_Stand_Alone_Library; 5170 5171 --------------------- 5172 -- Check_Unit_Name -- 5173 --------------------- 5174 5175 procedure Check_Unit_Name (Name : String; Unit : out Name_Id) is 5176 The_Name : String := Name; 5177 Real_Name : Name_Id; 5178 Need_Letter : Boolean := True; 5179 Last_Underscore : Boolean := False; 5180 OK : Boolean := The_Name'Length > 0; 5181 First : Positive; 5182 5183 function Is_Reserved (Name : Name_Id) return Boolean; 5184 function Is_Reserved (S : String) return Boolean; 5185 -- Check that the given name is not an Ada 95 reserved word. The reason 5186 -- for the Ada 95 here is that we do not want to exclude the case of an 5187 -- Ada 95 unit called Interface (for example). In Ada 2005, such a unit 5188 -- name would be rejected anyway by the compiler. That means there is no 5189 -- requirement that the project file parser reject this. 5190 5191 ----------------- 5192 -- Is_Reserved -- 5193 ----------------- 5194 5195 function Is_Reserved (S : String) return Boolean is 5196 begin 5197 Name_Len := 0; 5198 Add_Str_To_Name_Buffer (S); 5199 return Is_Reserved (Name_Find); 5200 end Is_Reserved; 5201 5202 ----------------- 5203 -- Is_Reserved -- 5204 ----------------- 5205 5206 function Is_Reserved (Name : Name_Id) return Boolean is 5207 begin 5208 if Get_Name_Table_Byte (Name) /= 0 5209 and then 5210 not Nam_In (Name, Name_Project, Name_Extends, Name_External) 5211 and then Name not in Ada_2005_Reserved_Words 5212 then 5213 Unit := No_Name; 5214 Debug_Output ("Ada reserved word: ", Name); 5215 return True; 5216 5217 else 5218 return False; 5219 end if; 5220 end Is_Reserved; 5221 5222 -- Start of processing for Check_Unit_Name 5223 5224 begin 5225 To_Lower (The_Name); 5226 5227 Name_Len := The_Name'Length; 5228 Name_Buffer (1 .. Name_Len) := The_Name; 5229 5230 Real_Name := Name_Find; 5231 5232 if Is_Reserved (Real_Name) then 5233 return; 5234 end if; 5235 5236 First := The_Name'First; 5237 5238 for Index in The_Name'Range loop 5239 if Need_Letter then 5240 5241 -- We need a letter (at the beginning, and following a dot), 5242 -- but we don't have one. 5243 5244 if Is_Letter (The_Name (Index)) then 5245 Need_Letter := False; 5246 5247 else 5248 OK := False; 5249 5250 if Current_Verbosity = High then 5251 Debug_Indent; 5252 Write_Int (Types.Int (Index)); 5253 Write_Str (": '"); 5254 Write_Char (The_Name (Index)); 5255 Write_Line ("' is not a letter."); 5256 end if; 5257 5258 exit; 5259 end if; 5260 5261 elsif Last_Underscore 5262 and then (The_Name (Index) = '_' or else The_Name (Index) = '.') 5263 then 5264 -- Two underscores are illegal, and a dot cannot follow 5265 -- an underscore. 5266 5267 OK := False; 5268 5269 if Current_Verbosity = High then 5270 Debug_Indent; 5271 Write_Int (Types.Int (Index)); 5272 Write_Str (": '"); 5273 Write_Char (The_Name (Index)); 5274 Write_Line ("' is illegal here."); 5275 end if; 5276 5277 exit; 5278 5279 elsif The_Name (Index) = '.' then 5280 5281 -- First, check if the name before the dot is not a reserved word 5282 5283 if Is_Reserved (The_Name (First .. Index - 1)) then 5284 return; 5285 end if; 5286 5287 First := Index + 1; 5288 5289 -- We need a letter after a dot 5290 5291 Need_Letter := True; 5292 5293 elsif The_Name (Index) = '_' then 5294 Last_Underscore := True; 5295 5296 else 5297 -- We need an letter or a digit 5298 5299 Last_Underscore := False; 5300 5301 if not Is_Alphanumeric (The_Name (Index)) then 5302 OK := False; 5303 5304 if Current_Verbosity = High then 5305 Debug_Indent; 5306 Write_Int (Types.Int (Index)); 5307 Write_Str (": '"); 5308 Write_Char (The_Name (Index)); 5309 Write_Line ("' is not alphanumeric."); 5310 end if; 5311 5312 exit; 5313 end if; 5314 end if; 5315 end loop; 5316 5317 -- Cannot end with an underscore or a dot 5318 5319 OK := OK and then not Need_Letter and then not Last_Underscore; 5320 5321 if OK then 5322 if First /= Name'First 5323 and then Is_Reserved (The_Name (First .. The_Name'Last)) 5324 then 5325 return; 5326 end if; 5327 5328 Unit := Real_Name; 5329 5330 else 5331 -- Signal a problem with No_Name 5332 5333 Unit := No_Name; 5334 end if; 5335 end Check_Unit_Name; 5336 5337 ---------------------------- 5338 -- Compute_Directory_Last -- 5339 ---------------------------- 5340 5341 function Compute_Directory_Last (Dir : String) return Natural is 5342 begin 5343 if Dir'Length > 1 5344 and then Is_Directory_Separator (Dir (Dir'Last - 1)) 5345 then 5346 return Dir'Last - 1; 5347 else 5348 return Dir'Last; 5349 end if; 5350 end Compute_Directory_Last; 5351 5352 --------------------- 5353 -- Get_Directories -- 5354 --------------------- 5355 5356 procedure Get_Directories 5357 (Project : Project_Id; 5358 Data : in out Tree_Processing_Data) 5359 is 5360 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; 5361 5362 Object_Dir : constant Variable_Value := 5363 Util.Value_Of 5364 (Name_Object_Dir, Project.Decl.Attributes, Shared); 5365 5366 Exec_Dir : constant Variable_Value := 5367 Util.Value_Of 5368 (Name_Exec_Dir, Project.Decl.Attributes, Shared); 5369 5370 Source_Dirs : constant Variable_Value := 5371 Util.Value_Of 5372 (Name_Source_Dirs, Project.Decl.Attributes, Shared); 5373 5374 Ignore_Source_Sub_Dirs : constant Variable_Value := 5375 Util.Value_Of 5376 (Name_Ignore_Source_Sub_Dirs, 5377 Project.Decl.Attributes, 5378 Shared); 5379 5380 Excluded_Source_Dirs : constant Variable_Value := 5381 Util.Value_Of 5382 (Name_Excluded_Source_Dirs, 5383 Project.Decl.Attributes, 5384 Shared); 5385 5386 Source_Files : constant Variable_Value := 5387 Util.Value_Of 5388 (Name_Source_Files, 5389 Project.Decl.Attributes, Shared); 5390 5391 Last_Source_Dir : String_List_Id := Nil_String; 5392 Last_Src_Dir_Rank : Number_List_Index := No_Number_List; 5393 5394 Languages : constant Variable_Value := 5395 Prj.Util.Value_Of 5396 (Name_Languages, Project.Decl.Attributes, Shared); 5397 5398 Remove_Source_Dirs : Boolean := False; 5399 5400 procedure Add_To_Or_Remove_From_Source_Dirs 5401 (Path : Path_Information; 5402 Rank : Natural); 5403 -- When Removed = False, the directory Path_Id to the list of 5404 -- source_dirs if not already in the list. When Removed = True, 5405 -- removed directory Path_Id if in the list. 5406 5407 procedure Find_Source_Dirs is new Expand_Subdirectory_Pattern 5408 (Add_To_Or_Remove_From_Source_Dirs); 5409 5410 --------------------------------------- 5411 -- Add_To_Or_Remove_From_Source_Dirs -- 5412 --------------------------------------- 5413 5414 procedure Add_To_Or_Remove_From_Source_Dirs 5415 (Path : Path_Information; 5416 Rank : Natural) 5417 is 5418 List : String_List_Id; 5419 Prev : String_List_Id; 5420 Rank_List : Number_List_Index; 5421 Prev_Rank : Number_List_Index; 5422 Element : String_Element; 5423 5424 begin 5425 Prev := Nil_String; 5426 Prev_Rank := No_Number_List; 5427 List := Project.Source_Dirs; 5428 Rank_List := Project.Source_Dir_Ranks; 5429 while List /= Nil_String loop 5430 Element := Shared.String_Elements.Table (List); 5431 exit when Element.Value = Name_Id (Path.Name); 5432 Prev := List; 5433 List := Element.Next; 5434 Prev_Rank := Rank_List; 5435 Rank_List := Shared.Number_Lists.Table (Prev_Rank).Next; 5436 end loop; 5437 5438 -- The directory is in the list if List is not Nil_String 5439 5440 if not Remove_Source_Dirs and then List = Nil_String then 5441 Debug_Output ("adding source dir=", Name_Id (Path.Display_Name)); 5442 5443 String_Element_Table.Increment_Last (Shared.String_Elements); 5444 Element := 5445 (Value => Name_Id (Path.Name), 5446 Index => 0, 5447 Display_Value => Name_Id (Path.Display_Name), 5448 Location => No_Location, 5449 Flag => False, 5450 Next => Nil_String); 5451 5452 Number_List_Table.Increment_Last (Shared.Number_Lists); 5453 5454 if Last_Source_Dir = Nil_String then 5455 5456 -- This is the first source directory 5457 5458 Project.Source_Dirs := 5459 String_Element_Table.Last (Shared.String_Elements); 5460 Project.Source_Dir_Ranks := 5461 Number_List_Table.Last (Shared.Number_Lists); 5462 5463 else 5464 -- We already have source directories, link the previous 5465 -- last to the new one. 5466 5467 Shared.String_Elements.Table (Last_Source_Dir).Next := 5468 String_Element_Table.Last (Shared.String_Elements); 5469 Shared.Number_Lists.Table (Last_Src_Dir_Rank).Next := 5470 Number_List_Table.Last (Shared.Number_Lists); 5471 end if; 5472 5473 -- And register this source directory as the new last 5474 5475 Last_Source_Dir := 5476 String_Element_Table.Last (Shared.String_Elements); 5477 Shared.String_Elements.Table (Last_Source_Dir) := Element; 5478 Last_Src_Dir_Rank := Number_List_Table.Last (Shared.Number_Lists); 5479 Shared.Number_Lists.Table (Last_Src_Dir_Rank) := 5480 (Number => Rank, Next => No_Number_List); 5481 5482 elsif Remove_Source_Dirs and then List /= Nil_String then 5483 5484 -- Remove source dir if present 5485 5486 if Prev = Nil_String then 5487 Project.Source_Dirs := Shared.String_Elements.Table (List).Next; 5488 Project.Source_Dir_Ranks := 5489 Shared.Number_Lists.Table (Rank_List).Next; 5490 5491 else 5492 Shared.String_Elements.Table (Prev).Next := 5493 Shared.String_Elements.Table (List).Next; 5494 Shared.Number_Lists.Table (Prev_Rank).Next := 5495 Shared.Number_Lists.Table (Rank_List).Next; 5496 end if; 5497 end if; 5498 end Add_To_Or_Remove_From_Source_Dirs; 5499 5500 -- Local declarations 5501 5502 Dir_Exists : Boolean; 5503 5504 No_Sources : constant Boolean := 5505 Project.Qualifier = Abstract_Project 5506 or else (((not Source_Files.Default 5507 and then Source_Files.Values = Nil_String) 5508 or else 5509 (not Source_Dirs.Default 5510 and then Source_Dirs.Values = Nil_String) 5511 or else 5512 (not Languages.Default 5513 and then Languages.Values = Nil_String)) 5514 and then Project.Extends = No_Project); 5515 5516 -- Start of processing for Get_Directories 5517 5518 begin 5519 Debug_Output ("starting to look for directories"); 5520 5521 -- Set the object directory to its default which may be nil, if there 5522 -- is no sources in the project. 5523 5524 if No_Sources then 5525 Project.Object_Directory := No_Path_Information; 5526 else 5527 Project.Object_Directory := Project.Directory; 5528 end if; 5529 5530 -- Check the object directory 5531 5532 if Object_Dir.Value /= Empty_String then 5533 Get_Name_String (Object_Dir.Value); 5534 5535 if Name_Len = 0 then 5536 Error_Msg 5537 (Data.Flags, 5538 "Object_Dir cannot be empty", 5539 Object_Dir.Location, Project); 5540 5541 elsif Setup_Projects 5542 and then No_Sources 5543 and then Project.Extends = No_Project 5544 then 5545 -- Do not create an object directory for a non extending project 5546 -- with no sources. 5547 5548 Locate_Directory 5549 (Project, 5550 File_Name_Type (Object_Dir.Value), 5551 Path => Project.Object_Directory, 5552 Dir_Exists => Dir_Exists, 5553 Data => Data, 5554 Location => Object_Dir.Location, 5555 Must_Exist => False, 5556 Externally_Built => Project.Externally_Built); 5557 5558 else 5559 -- We check that the specified object directory does exist. 5560 -- However, even when it doesn't exist, we set it to a default 5561 -- value. This is for the benefit of tools that recover from 5562 -- errors; for example, these tools could create the non existent 5563 -- directory. We always return an absolute directory name though. 5564 5565 Locate_Directory 5566 (Project, 5567 File_Name_Type (Object_Dir.Value), 5568 Path => Project.Object_Directory, 5569 Create => "object", 5570 Dir_Exists => Dir_Exists, 5571 Data => Data, 5572 Location => Object_Dir.Location, 5573 Must_Exist => False, 5574 Externally_Built => Project.Externally_Built); 5575 5576 if not Dir_Exists and then not Project.Externally_Built then 5577 if Opt.Directories_Must_Exist_In_Projects then 5578 5579 -- The object directory does not exist, report an error if 5580 -- the project is not externally built. 5581 5582 Err_Vars.Error_Msg_File_1 := 5583 File_Name_Type (Object_Dir.Value); 5584 Error_Or_Warning 5585 (Data.Flags, Data.Flags.Require_Obj_Dirs, 5586 "object directory { not found", 5587 Project.Location, Project); 5588 end if; 5589 end if; 5590 end if; 5591 5592 elsif not No_Sources 5593 and then (Subdirs /= null or else Build_Tree_Dir /= null) 5594 then 5595 Name_Len := 1; 5596 Name_Buffer (1) := '.'; 5597 Locate_Directory 5598 (Project, 5599 Name_Find, 5600 Path => Project.Object_Directory, 5601 Create => "object", 5602 Dir_Exists => Dir_Exists, 5603 Data => Data, 5604 Location => Object_Dir.Location, 5605 Externally_Built => Project.Externally_Built); 5606 end if; 5607 5608 if Current_Verbosity = High then 5609 if Project.Object_Directory = No_Path_Information then 5610 Debug_Output ("no object directory"); 5611 else 5612 Write_Attr 5613 ("Object directory", 5614 Get_Name_String (Project.Object_Directory.Display_Name)); 5615 end if; 5616 end if; 5617 5618 -- Check the exec directory 5619 5620 -- We set the object directory to its default 5621 5622 Project.Exec_Directory := Project.Object_Directory; 5623 5624 if Exec_Dir.Value /= Empty_String then 5625 Get_Name_String (Exec_Dir.Value); 5626 5627 if Name_Len = 0 then 5628 Error_Msg 5629 (Data.Flags, 5630 "Exec_Dir cannot be empty", 5631 Exec_Dir.Location, Project); 5632 5633 elsif Setup_Projects 5634 and then No_Sources 5635 and then Project.Extends = No_Project 5636 then 5637 -- Do not create an exec directory for a non extending project 5638 -- with no sources. 5639 5640 Locate_Directory 5641 (Project, 5642 File_Name_Type (Exec_Dir.Value), 5643 Path => Project.Exec_Directory, 5644 Dir_Exists => Dir_Exists, 5645 Data => Data, 5646 Location => Exec_Dir.Location, 5647 Externally_Built => Project.Externally_Built); 5648 5649 else 5650 -- We check that the specified exec directory does exist 5651 5652 Locate_Directory 5653 (Project, 5654 File_Name_Type (Exec_Dir.Value), 5655 Path => Project.Exec_Directory, 5656 Dir_Exists => Dir_Exists, 5657 Data => Data, 5658 Create => "exec", 5659 Location => Exec_Dir.Location, 5660 Externally_Built => Project.Externally_Built); 5661 5662 if not Dir_Exists then 5663 if Opt.Directories_Must_Exist_In_Projects then 5664 Err_Vars.Error_Msg_File_1 := File_Name_Type (Exec_Dir.Value); 5665 Error_Or_Warning 5666 (Data.Flags, Data.Flags.Missing_Source_Files, 5667 "exec directory { not found", Project.Location, Project); 5668 5669 else 5670 Project.Exec_Directory := No_Path_Information; 5671 end if; 5672 end if; 5673 end if; 5674 end if; 5675 5676 if Current_Verbosity = High then 5677 if Project.Exec_Directory = No_Path_Information then 5678 Debug_Output ("no exec directory"); 5679 else 5680 Debug_Output 5681 ("exec directory: ", 5682 Name_Id (Project.Exec_Directory.Display_Name)); 5683 end if; 5684 end if; 5685 5686 -- Look for the source directories 5687 5688 Debug_Output ("starting to look for source directories"); 5689 5690 pragma Assert (Source_Dirs.Kind = List, "Source_Dirs is not a list"); 5691 5692 if not Source_Files.Default and then Source_Files.Values = Nil_String 5693 then 5694 Project.Source_Dirs := Nil_String; 5695 5696 if Project.Qualifier = Standard then 5697 Error_Msg 5698 (Data.Flags, 5699 "a standard project cannot have no sources", 5700 Source_Files.Location, Project); 5701 end if; 5702 5703 elsif Source_Dirs.Default then 5704 5705 -- No Source_Dirs specified: the single source directory is the one 5706 -- containing the project file. 5707 5708 Remove_Source_Dirs := False; 5709 Add_To_Or_Remove_From_Source_Dirs 5710 (Path => (Name => Project.Directory.Name, 5711 Display_Name => Project.Directory.Display_Name), 5712 Rank => 1); 5713 5714 else 5715 Remove_Source_Dirs := False; 5716 Find_Source_Dirs 5717 (Project => Project, 5718 Data => Data, 5719 Patterns => Source_Dirs.Values, 5720 Ignore => Ignore_Source_Sub_Dirs.Values, 5721 Search_For => Search_Directories, 5722 Resolve_Links => Opt.Follow_Links_For_Dirs); 5723 5724 if Project.Source_Dirs = Nil_String 5725 and then Project.Qualifier = Standard 5726 then 5727 Error_Msg 5728 (Data.Flags, 5729 "a standard project cannot have no source directories", 5730 Source_Dirs.Location, Project); 5731 end if; 5732 end if; 5733 5734 if not Excluded_Source_Dirs.Default 5735 and then Excluded_Source_Dirs.Values /= Nil_String 5736 then 5737 Remove_Source_Dirs := True; 5738 Find_Source_Dirs 5739 (Project => Project, 5740 Data => Data, 5741 Patterns => Excluded_Source_Dirs.Values, 5742 Ignore => Nil_String, 5743 Search_For => Search_Directories, 5744 Resolve_Links => Opt.Follow_Links_For_Dirs); 5745 end if; 5746 5747 Debug_Output ("putting source directories in canonical cases"); 5748 5749 declare 5750 Current : String_List_Id := Project.Source_Dirs; 5751 Element : String_Element; 5752 5753 begin 5754 while Current /= Nil_String loop 5755 Element := Shared.String_Elements.Table (Current); 5756 if Element.Value /= No_Name then 5757 Element.Value := 5758 Name_Id (Canonical_Case_File_Name (Element.Value)); 5759 Shared.String_Elements.Table (Current) := Element; 5760 end if; 5761 5762 Current := Element.Next; 5763 end loop; 5764 end; 5765 end Get_Directories; 5766 5767 --------------- 5768 -- Get_Mains -- 5769 --------------- 5770 5771 procedure Get_Mains 5772 (Project : Project_Id; 5773 Data : in out Tree_Processing_Data) 5774 is 5775 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; 5776 5777 Mains : constant Variable_Value := 5778 Prj.Util.Value_Of 5779 (Name_Main, Project.Decl.Attributes, Shared); 5780 List : String_List_Id; 5781 Elem : String_Element; 5782 5783 begin 5784 Project.Mains := Mains.Values; 5785 5786 -- If no Mains were specified, and if we are an extending project, 5787 -- inherit the Mains from the project we are extending. 5788 5789 if Mains.Default then 5790 if not Project.Library and then Project.Extends /= No_Project then 5791 Project.Mains := Project.Extends.Mains; 5792 end if; 5793 5794 -- In a library project file, Main cannot be specified 5795 5796 elsif Project.Library then 5797 Error_Msg 5798 (Data.Flags, 5799 "a library project file cannot have Main specified", 5800 Mains.Location, Project); 5801 5802 else 5803 List := Mains.Values; 5804 while List /= Nil_String loop 5805 Elem := Shared.String_Elements.Table (List); 5806 5807 if Length_Of_Name (Elem.Value) = 0 then 5808 Error_Msg 5809 (Data.Flags, 5810 "?a main cannot have an empty name", 5811 Elem.Location, Project); 5812 exit; 5813 end if; 5814 5815 List := Elem.Next; 5816 end loop; 5817 end if; 5818 end Get_Mains; 5819 5820 --------------------------- 5821 -- Get_Sources_From_File -- 5822 --------------------------- 5823 5824 procedure Get_Sources_From_File 5825 (Path : String; 5826 Location : Source_Ptr; 5827 Project : in out Project_Processing_Data; 5828 Data : in out Tree_Processing_Data) 5829 is 5830 File : Prj.Util.Text_File; 5831 Line : String (1 .. 250); 5832 Last : Natural; 5833 Source_Name : File_Name_Type; 5834 Name_Loc : Name_Location; 5835 5836 begin 5837 if Current_Verbosity = High then 5838 Debug_Output ("opening """ & Path & '"'); 5839 end if; 5840 5841 -- Open the file 5842 5843 Prj.Util.Open (File, Path); 5844 5845 if not Prj.Util.Is_Valid (File) then 5846 Error_Msg 5847 (Data.Flags, "file does not exist", Location, Project.Project); 5848 5849 else 5850 -- Read the lines one by one 5851 5852 while not Prj.Util.End_Of_File (File) loop 5853 Prj.Util.Get_Line (File, Line, Last); 5854 5855 -- A non empty, non comment line should contain a file name 5856 5857 if Last /= 0 and then (Last = 1 or else Line (1 .. 2) /= "--") then 5858 Name_Len := Last; 5859 Name_Buffer (1 .. Name_Len) := Line (1 .. Last); 5860 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); 5861 Source_Name := Name_Find; 5862 5863 -- Check that there is no directory information 5864 5865 for J in 1 .. Last loop 5866 if Is_Directory_Separator (Line (J)) then 5867 Error_Msg_File_1 := Source_Name; 5868 Error_Msg 5869 (Data.Flags, 5870 "file name cannot include directory information ({)", 5871 Location, Project.Project); 5872 exit; 5873 end if; 5874 end loop; 5875 5876 Name_Loc := Source_Names_Htable.Get 5877 (Project.Source_Names, Source_Name); 5878 5879 if Name_Loc = No_Name_Location then 5880 Name_Loc := 5881 (Name => Source_Name, 5882 Location => Location, 5883 Source => No_Source, 5884 Listed => True, 5885 Found => False); 5886 5887 else 5888 Name_Loc.Listed := True; 5889 end if; 5890 5891 Source_Names_Htable.Set 5892 (Project.Source_Names, Source_Name, Name_Loc); 5893 end if; 5894 end loop; 5895 5896 Prj.Util.Close (File); 5897 5898 end if; 5899 end Get_Sources_From_File; 5900 5901 ------------------ 5902 -- No_Space_Img -- 5903 ------------------ 5904 5905 function No_Space_Img (N : Natural) return String is 5906 Image : constant String := N'Img; 5907 begin 5908 return Image (2 .. Image'Last); 5909 end No_Space_Img; 5910 5911 ----------------------- 5912 -- Compute_Unit_Name -- 5913 ----------------------- 5914 5915 procedure Compute_Unit_Name 5916 (File_Name : File_Name_Type; 5917 Naming : Lang_Naming_Data; 5918 Kind : out Source_Kind; 5919 Unit : out Name_Id; 5920 Project : Project_Processing_Data) 5921 is 5922 Filename : constant String := Get_Name_String (File_Name); 5923 Last : Integer := Filename'Last; 5924 Sep_Len : Integer; 5925 Body_Len : Integer; 5926 Spec_Len : Integer; 5927 5928 Unit_Except : Unit_Exception; 5929 Masked : Boolean := False; 5930 5931 begin 5932 Unit := No_Name; 5933 Kind := Spec; 5934 5935 if Naming.Separate_Suffix = No_File 5936 or else Naming.Body_Suffix = No_File 5937 or else Naming.Spec_Suffix = No_File 5938 then 5939 return; 5940 end if; 5941 5942 if Naming.Dot_Replacement = No_File then 5943 Debug_Output ("no dot_replacement specified"); 5944 return; 5945 end if; 5946 5947 Sep_Len := Integer (Length_Of_Name (Naming.Separate_Suffix)); 5948 Spec_Len := Integer (Length_Of_Name (Naming.Spec_Suffix)); 5949 Body_Len := Integer (Length_Of_Name (Naming.Body_Suffix)); 5950 5951 -- Choose the longest suffix that matches. If there are several matches, 5952 -- give priority to specs, then bodies, then separates. 5953 5954 if Naming.Separate_Suffix /= Naming.Body_Suffix 5955 and then Suffix_Matches (Filename, Naming.Separate_Suffix) 5956 then 5957 Last := Filename'Last - Sep_Len; 5958 Kind := Sep; 5959 end if; 5960 5961 if Filename'Last - Body_Len <= Last 5962 and then Suffix_Matches (Filename, Naming.Body_Suffix) 5963 then 5964 Last := Natural'Min (Last, Filename'Last - Body_Len); 5965 Kind := Impl; 5966 end if; 5967 5968 if Filename'Last - Spec_Len <= Last 5969 and then Suffix_Matches (Filename, Naming.Spec_Suffix) 5970 then 5971 Last := Natural'Min (Last, Filename'Last - Spec_Len); 5972 Kind := Spec; 5973 end if; 5974 5975 if Last = Filename'Last then 5976 Debug_Output ("no matching suffix"); 5977 return; 5978 end if; 5979 5980 -- Check that the casing matches 5981 5982 if File_Names_Case_Sensitive then 5983 case Naming.Casing is 5984 when All_Lower_Case => 5985 for J in Filename'First .. Last loop 5986 if Is_Letter (Filename (J)) 5987 and then not Is_Lower (Filename (J)) 5988 then 5989 Debug_Output ("invalid casing"); 5990 return; 5991 end if; 5992 end loop; 5993 5994 when All_Upper_Case => 5995 for J in Filename'First .. Last loop 5996 if Is_Letter (Filename (J)) 5997 and then not Is_Upper (Filename (J)) 5998 then 5999 Debug_Output ("invalid casing"); 6000 return; 6001 end if; 6002 end loop; 6003 6004 when Mixed_Case | Unknown => 6005 null; 6006 end case; 6007 end if; 6008 6009 -- If Dot_Replacement is not a single dot, then there should not 6010 -- be any dot in the name. 6011 6012 declare 6013 Dot_Repl : constant String := 6014 Get_Name_String (Naming.Dot_Replacement); 6015 6016 begin 6017 if Dot_Repl /= "." then 6018 for Index in Filename'First .. Last loop 6019 if Filename (Index) = '.' then 6020 Debug_Output ("invalid name, contains dot"); 6021 return; 6022 end if; 6023 end loop; 6024 6025 Replace_Into_Name_Buffer 6026 (Filename (Filename'First .. Last), Dot_Repl, '.'); 6027 6028 else 6029 Name_Len := Last - Filename'First + 1; 6030 Name_Buffer (1 .. Name_Len) := Filename (Filename'First .. Last); 6031 Fixed.Translate 6032 (Source => Name_Buffer (1 .. Name_Len), 6033 Mapping => Lower_Case_Map); 6034 end if; 6035 end; 6036 6037 -- In the standard GNAT naming scheme, check for special cases: children 6038 -- or separates of A, G, I or S, and run time sources. 6039 6040 if Is_Standard_GNAT_Naming (Naming) and then Name_Len >= 3 then 6041 declare 6042 S1 : constant Character := Name_Buffer (1); 6043 S2 : constant Character := Name_Buffer (2); 6044 S3 : constant Character := Name_Buffer (3); 6045 6046 begin 6047 if S1 = 'a' or else S1 = 'g' or else S1 = 'i' or else S1 = 's' then 6048 6049 -- Children or separates of packages A, G, I or S. These names 6050 -- are x__ ... or x~... (where x is a, g, i, or s). Both 6051 -- versions (x__... and x~...) are allowed in all platforms, 6052 -- because it is not possible to know the platform before 6053 -- processing of the project files. 6054 6055 if S2 = '_' and then S3 = '_' then 6056 Name_Buffer (2) := '.'; 6057 Name_Buffer (3 .. Name_Len - 1) := 6058 Name_Buffer (4 .. Name_Len); 6059 Name_Len := Name_Len - 1; 6060 6061 elsif S2 = '~' then 6062 Name_Buffer (2) := '.'; 6063 6064 elsif S2 = '.' then 6065 6066 -- If it is potentially a run time source 6067 6068 null; 6069 end if; 6070 end if; 6071 end; 6072 end if; 6073 6074 -- Name_Buffer contains the name of the unit in lower-cases. Check 6075 -- that this is a valid unit name 6076 6077 Check_Unit_Name (Name_Buffer (1 .. Name_Len), Unit); 6078 6079 -- If there is a naming exception for the same unit, the file is not 6080 -- a source for the unit. 6081 6082 if Unit /= No_Name then 6083 Unit_Except := 6084 Unit_Exceptions_Htable.Get (Project.Unit_Exceptions, Unit); 6085 6086 if Kind = Spec then 6087 Masked := Unit_Except.Spec /= No_File 6088 and then 6089 Unit_Except.Spec /= File_Name; 6090 else 6091 Masked := Unit_Except.Impl /= No_File 6092 and then 6093 Unit_Except.Impl /= File_Name; 6094 end if; 6095 6096 if Masked then 6097 if Current_Verbosity = High then 6098 Debug_Indent; 6099 Write_Str (" """ & Filename & """ contains the "); 6100 6101 if Kind = Spec then 6102 Write_Str ("spec of a unit found in """); 6103 Write_Str (Get_Name_String (Unit_Except.Spec)); 6104 else 6105 Write_Str ("body of a unit found in """); 6106 Write_Str (Get_Name_String (Unit_Except.Impl)); 6107 end if; 6108 6109 Write_Line (""" (ignored)"); 6110 end if; 6111 6112 Unit := No_Name; 6113 end if; 6114 end if; 6115 6116 if Unit /= No_Name and then Current_Verbosity = High then 6117 case Kind is 6118 when Spec => Debug_Output ("spec of", Unit); 6119 when Impl => Debug_Output ("body of", Unit); 6120 when Sep => Debug_Output ("sep of", Unit); 6121 end case; 6122 end if; 6123 end Compute_Unit_Name; 6124 6125 -------------------------- 6126 -- Check_Illegal_Suffix -- 6127 -------------------------- 6128 6129 procedure Check_Illegal_Suffix 6130 (Project : Project_Id; 6131 Suffix : File_Name_Type; 6132 Dot_Replacement : File_Name_Type; 6133 Attribute_Name : String; 6134 Location : Source_Ptr; 6135 Data : in out Tree_Processing_Data) 6136 is 6137 Suffix_Str : constant String := Get_Name_String (Suffix); 6138 6139 begin 6140 if Suffix_Str'Length = 0 then 6141 6142 -- Always valid 6143 6144 return; 6145 6146 elsif Index (Suffix_Str, ".") = 0 then 6147 Err_Vars.Error_Msg_File_1 := Suffix; 6148 Error_Msg 6149 (Data.Flags, 6150 "{ is illegal for " & Attribute_Name & ": must have a dot", 6151 Location, Project); 6152 return; 6153 end if; 6154 6155 -- Case of dot replacement is a single dot, and first character of 6156 -- suffix is also a dot. 6157 6158 if Dot_Replacement /= No_File 6159 and then Get_Name_String (Dot_Replacement) = "." 6160 and then Suffix_Str (Suffix_Str'First) = '.' 6161 then 6162 for Index in Suffix_Str'First + 1 .. Suffix_Str'Last loop 6163 6164 -- If there are multiple dots in the name 6165 6166 if Suffix_Str (Index) = '.' then 6167 6168 -- It is illegal to have a letter following the initial dot 6169 6170 if Is_Letter (Suffix_Str (Suffix_Str'First + 1)) then 6171 Err_Vars.Error_Msg_File_1 := Suffix; 6172 Error_Msg 6173 (Data.Flags, 6174 "{ is illegal for " & Attribute_Name 6175 & ": ambiguous prefix when Dot_Replacement is a dot", 6176 Location, Project); 6177 end if; 6178 return; 6179 end if; 6180 end loop; 6181 end if; 6182 end Check_Illegal_Suffix; 6183 6184 ---------------------- 6185 -- Locate_Directory -- 6186 ---------------------- 6187 6188 procedure Locate_Directory 6189 (Project : Project_Id; 6190 Name : File_Name_Type; 6191 Path : out Path_Information; 6192 Dir_Exists : out Boolean; 6193 Data : in out Tree_Processing_Data; 6194 Create : String := ""; 6195 Location : Source_Ptr := No_Location; 6196 Must_Exist : Boolean := True; 6197 Externally_Built : Boolean := False) 6198 is 6199 Parent : constant Path_Name_Type := 6200 Project.Directory.Display_Name; 6201 The_Parent : constant String := 6202 Get_Name_String (Parent); 6203 The_Parent_Last : constant Natural := 6204 Compute_Directory_Last (The_Parent); 6205 Full_Name : File_Name_Type; 6206 The_Name : File_Name_Type; 6207 6208 begin 6209 -- Check if we have a root-object dir specified, if so relocate all 6210 -- artefact directories to it. 6211 6212 if Build_Tree_Dir /= null 6213 and then Create /= "" 6214 and then not Is_Absolute_Path (Get_Name_String (Name)) 6215 then 6216 Name_Len := 0; 6217 Add_Str_To_Name_Buffer (Build_Tree_Dir.all); 6218 6219 if The_Parent_Last - The_Parent'First + 1 < Root_Dir'Length then 6220 Err_Vars.Error_Msg_File_1 := Name; 6221 Error_Or_Warning 6222 (Data.Flags, Error, 6223 "{ cannot relocate deeper than " & Create & " directory", 6224 No_Location, Project); 6225 end if; 6226 6227 Add_Str_To_Name_Buffer 6228 (Relative_Path 6229 (The_Parent (The_Parent'First .. The_Parent_Last), 6230 Root_Dir.all)); 6231 Add_Str_To_Name_Buffer (Get_Name_String (Name)); 6232 6233 else 6234 if Build_Tree_Dir /= null and then Create /= "" then 6235 6236 -- Issue a warning that we cannot relocate absolute obj dir 6237 6238 Err_Vars.Error_Msg_File_1 := Name; 6239 Error_Or_Warning 6240 (Data.Flags, Warning, 6241 "{ cannot relocate absolute object directory", 6242 No_Location, Project); 6243 end if; 6244 6245 Get_Name_String (Name); 6246 end if; 6247 6248 -- Add Subdirs.all if it is a directory that may be created and 6249 -- Subdirs is not null; 6250 6251 if Create /= "" and then Subdirs /= null then 6252 if Name_Buffer (Name_Len) /= Directory_Separator then 6253 Add_Char_To_Name_Buffer (Directory_Separator); 6254 end if; 6255 6256 Add_Str_To_Name_Buffer (Subdirs.all); 6257 end if; 6258 6259 -- Convert '/' to directory separator (for Windows) 6260 6261 for J in 1 .. Name_Len loop 6262 if Name_Buffer (J) = '/' then 6263 Name_Buffer (J) := Directory_Separator; 6264 end if; 6265 end loop; 6266 6267 The_Name := Name_Find; 6268 6269 if Current_Verbosity = High then 6270 Debug_Indent; 6271 Write_Str ("Locate_Directory ("""); 6272 Write_Str (Get_Name_String (The_Name)); 6273 Write_Str (""", in """); 6274 Write_Str (The_Parent); 6275 Write_Line (""")"); 6276 end if; 6277 6278 Path := No_Path_Information; 6279 Dir_Exists := False; 6280 6281 if Is_Absolute_Path (Get_Name_String (The_Name)) then 6282 Full_Name := The_Name; 6283 6284 else 6285 Name_Len := 0; 6286 Add_Str_To_Name_Buffer 6287 (The_Parent (The_Parent'First .. The_Parent_Last)); 6288 Add_Str_To_Name_Buffer (Get_Name_String (The_Name)); 6289 Full_Name := Name_Find; 6290 end if; 6291 6292 declare 6293 Full_Path_Name : String_Access := 6294 new String'(Get_Name_String (Full_Name)); 6295 6296 begin 6297 if (Setup_Projects or else Subdirs /= null) 6298 and then Create'Length > 0 6299 then 6300 if not Is_Directory (Full_Path_Name.all) then 6301 6302 -- If project is externally built, do not create a subdir, 6303 -- use the specified directory, without the subdir. 6304 6305 if Externally_Built then 6306 if Is_Absolute_Path (Get_Name_String (Name)) then 6307 Get_Name_String (Name); 6308 6309 else 6310 Name_Len := 0; 6311 Add_Str_To_Name_Buffer 6312 (The_Parent (The_Parent'First .. The_Parent_Last)); 6313 Add_Str_To_Name_Buffer (Get_Name_String (Name)); 6314 end if; 6315 6316 Full_Path_Name := new String'(Name_Buffer (1 .. Name_Len)); 6317 6318 else 6319 begin 6320 Create_Path (Full_Path_Name.all); 6321 6322 if not Quiet_Output then 6323 Write_Str (Create); 6324 Write_Str (" directory """); 6325 Write_Str (Full_Path_Name.all); 6326 Write_Str (""" created for project "); 6327 Write_Line (Get_Name_String (Project.Name)); 6328 end if; 6329 6330 exception 6331 when Use_Error => 6332 6333 -- Output message with name of directory. Note that we 6334 -- use the ~ insertion method here in case the name 6335 -- has special characters in it. 6336 6337 Error_Msg_Strlen := Full_Path_Name'Length; 6338 Error_Msg_String (1 .. Error_Msg_Strlen) := 6339 Full_Path_Name.all; 6340 Error_Msg 6341 (Data.Flags, 6342 "could not create " & Create & " directory ~", 6343 Location, 6344 Project); 6345 end; 6346 end if; 6347 end if; 6348 end if; 6349 6350 Dir_Exists := Is_Directory (Full_Path_Name.all); 6351 6352 if not Must_Exist or Dir_Exists then 6353 declare 6354 Normed : constant String := 6355 Normalize_Pathname 6356 (Full_Path_Name.all, 6357 Directory => 6358 The_Parent (The_Parent'First .. The_Parent_Last), 6359 Resolve_Links => False, 6360 Case_Sensitive => True); 6361 6362 Canonical_Path : constant String := 6363 Normalize_Pathname 6364 (Normed, 6365 Directory => 6366 The_Parent 6367 (The_Parent'First .. The_Parent_Last), 6368 Resolve_Links => 6369 Opt.Follow_Links_For_Dirs, 6370 Case_Sensitive => False); 6371 6372 begin 6373 Name_Len := Normed'Length; 6374 Name_Buffer (1 .. Name_Len) := Normed; 6375 6376 -- Directories should always end with a directory separator 6377 6378 if Name_Buffer (Name_Len) /= Directory_Separator then 6379 Add_Char_To_Name_Buffer (Directory_Separator); 6380 end if; 6381 6382 Path.Display_Name := Name_Find; 6383 6384 Name_Len := Canonical_Path'Length; 6385 Name_Buffer (1 .. Name_Len) := Canonical_Path; 6386 6387 if Name_Buffer (Name_Len) /= Directory_Separator then 6388 Add_Char_To_Name_Buffer (Directory_Separator); 6389 end if; 6390 6391 Path.Name := Name_Find; 6392 end; 6393 end if; 6394 6395 Free (Full_Path_Name); 6396 end; 6397 end Locate_Directory; 6398 6399 --------------------------- 6400 -- Find_Excluded_Sources -- 6401 --------------------------- 6402 6403 procedure Find_Excluded_Sources 6404 (Project : in out Project_Processing_Data; 6405 Data : in out Tree_Processing_Data) 6406 is 6407 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; 6408 6409 Excluded_Source_List_File : constant Variable_Value := 6410 Util.Value_Of 6411 (Name_Excluded_Source_List_File, 6412 Project.Project.Decl.Attributes, 6413 Shared); 6414 Excluded_Sources : Variable_Value := Util.Value_Of 6415 (Name_Excluded_Source_Files, 6416 Project.Project.Decl.Attributes, 6417 Shared); 6418 6419 Current : String_List_Id; 6420 Element : String_Element; 6421 Location : Source_Ptr; 6422 Name : File_Name_Type; 6423 File : Prj.Util.Text_File; 6424 Line : String (1 .. 300); 6425 Last : Natural; 6426 Locally_Removed : Boolean := False; 6427 6428 begin 6429 -- If Excluded_Source_Files is not declared, check Locally_Removed_Files 6430 6431 if Excluded_Sources.Default then 6432 Locally_Removed := True; 6433 Excluded_Sources := 6434 Util.Value_Of 6435 (Name_Locally_Removed_Files, 6436 Project.Project.Decl.Attributes, Shared); 6437 end if; 6438 6439 -- If there are excluded sources, put them in the table 6440 6441 if not Excluded_Sources.Default then 6442 if not Excluded_Source_List_File.Default then 6443 if Locally_Removed then 6444 Error_Msg 6445 (Data.Flags, 6446 "?both attributes Locally_Removed_Files and " & 6447 "Excluded_Source_List_File are present", 6448 Excluded_Source_List_File.Location, Project.Project); 6449 else 6450 Error_Msg 6451 (Data.Flags, 6452 "?both attributes Excluded_Source_Files and " & 6453 "Excluded_Source_List_File are present", 6454 Excluded_Source_List_File.Location, Project.Project); 6455 end if; 6456 end if; 6457 6458 Current := Excluded_Sources.Values; 6459 while Current /= Nil_String loop 6460 Element := Shared.String_Elements.Table (Current); 6461 Name := Canonical_Case_File_Name (Element.Value); 6462 6463 -- If the element has no location, then use the location of 6464 -- Excluded_Sources to report possible errors. 6465 6466 if Element.Location = No_Location then 6467 Location := Excluded_Sources.Location; 6468 else 6469 Location := Element.Location; 6470 end if; 6471 6472 Excluded_Sources_Htable.Set 6473 (Project.Excluded, Name, 6474 (Name, No_File, 0, False, Location)); 6475 Current := Element.Next; 6476 end loop; 6477 6478 elsif not Excluded_Source_List_File.Default then 6479 Location := Excluded_Source_List_File.Location; 6480 6481 declare 6482 Source_File_Name : constant File_Name_Type := 6483 File_Name_Type 6484 (Excluded_Source_List_File.Value); 6485 Source_File_Line : Natural := 0; 6486 6487 Source_File_Path_Name : constant String := 6488 Path_Name_Of 6489 (Source_File_Name, 6490 Project.Project.Directory.Name); 6491 6492 begin 6493 if Source_File_Path_Name'Length = 0 then 6494 Err_Vars.Error_Msg_File_1 := 6495 File_Name_Type (Excluded_Source_List_File.Value); 6496 Error_Msg 6497 (Data.Flags, 6498 "file with excluded sources { does not exist", 6499 Excluded_Source_List_File.Location, Project.Project); 6500 6501 else 6502 -- Open the file 6503 6504 Prj.Util.Open (File, Source_File_Path_Name); 6505 6506 if not Prj.Util.Is_Valid (File) then 6507 Error_Msg 6508 (Data.Flags, "file does not exist", 6509 Location, Project.Project); 6510 else 6511 -- Read the lines one by one 6512 6513 while not Prj.Util.End_Of_File (File) loop 6514 Prj.Util.Get_Line (File, Line, Last); 6515 Source_File_Line := Source_File_Line + 1; 6516 6517 -- Non empty, non comment line should contain a file name 6518 6519 if Last /= 0 6520 and then (Last = 1 or else Line (1 .. 2) /= "--") 6521 then 6522 Name_Len := Last; 6523 Name_Buffer (1 .. Name_Len) := Line (1 .. Last); 6524 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); 6525 Name := Name_Find; 6526 6527 -- Check that there is no directory information 6528 6529 for J in 1 .. Last loop 6530 if Is_Directory_Separator (Line (J)) then 6531 Error_Msg_File_1 := Name; 6532 Error_Msg 6533 (Data.Flags, 6534 "file name cannot include " 6535 & "directory information ({)", 6536 Location, Project.Project); 6537 exit; 6538 end if; 6539 end loop; 6540 6541 Excluded_Sources_Htable.Set 6542 (Project.Excluded, 6543 Name, 6544 (Name, Source_File_Name, Source_File_Line, 6545 False, Location)); 6546 end if; 6547 end loop; 6548 6549 Prj.Util.Close (File); 6550 end if; 6551 end if; 6552 end; 6553 end if; 6554 end Find_Excluded_Sources; 6555 6556 ------------------ 6557 -- Find_Sources -- 6558 ------------------ 6559 6560 procedure Find_Sources 6561 (Project : in out Project_Processing_Data; 6562 Data : in out Tree_Processing_Data) 6563 is 6564 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; 6565 6566 Sources : constant Variable_Value := 6567 Util.Value_Of 6568 (Name_Source_Files, 6569 Project.Project.Decl.Attributes, 6570 Shared); 6571 6572 Source_List_File : constant Variable_Value := 6573 Util.Value_Of 6574 (Name_Source_List_File, 6575 Project.Project.Decl.Attributes, 6576 Shared); 6577 6578 Name_Loc : Name_Location; 6579 Has_Explicit_Sources : Boolean; 6580 6581 begin 6582 pragma Assert (Sources.Kind = List, "Source_Files is not a list"); 6583 pragma Assert 6584 (Source_List_File.Kind = Single, 6585 "Source_List_File is not a single string"); 6586 6587 Project.Source_List_File_Location := Source_List_File.Location; 6588 6589 -- If the user has specified a Source_Files attribute 6590 6591 if not Sources.Default then 6592 if not Source_List_File.Default then 6593 Error_Msg 6594 (Data.Flags, 6595 "?both attributes source_files and " & 6596 "source_list_file are present", 6597 Source_List_File.Location, Project.Project); 6598 end if; 6599 6600 -- Sources is a list of file names 6601 6602 declare 6603 Current : String_List_Id := Sources.Values; 6604 Element : String_Element; 6605 Location : Source_Ptr; 6606 Name : File_Name_Type; 6607 6608 begin 6609 if Current = Nil_String then 6610 Project.Project.Languages := No_Language_Index; 6611 6612 -- This project contains no source. For projects that don't 6613 -- extend other projects, this also means that there is no 6614 -- need for an object directory, if not specified. 6615 6616 if Project.Project.Extends = No_Project 6617 and then 6618 Project.Project.Object_Directory = Project.Project.Directory 6619 and then not (Project.Project.Qualifier = Aggregate_Library) 6620 then 6621 Project.Project.Object_Directory := No_Path_Information; 6622 end if; 6623 end if; 6624 6625 while Current /= Nil_String loop 6626 Element := Shared.String_Elements.Table (Current); 6627 Name := Canonical_Case_File_Name (Element.Value); 6628 Get_Name_String (Element.Value); 6629 6630 -- If the element has no location, then use the location of 6631 -- Sources to report possible errors. 6632 6633 if Element.Location = No_Location then 6634 Location := Sources.Location; 6635 else 6636 Location := Element.Location; 6637 end if; 6638 6639 -- Check that there is no directory information 6640 6641 for J in 1 .. Name_Len loop 6642 if Is_Directory_Separator (Name_Buffer (J)) then 6643 Error_Msg_File_1 := Name; 6644 Error_Msg 6645 (Data.Flags, 6646 "file name cannot include directory " & 6647 "information ({)", 6648 Location, Project.Project); 6649 exit; 6650 end if; 6651 end loop; 6652 6653 -- Check whether the file is already there: the same file name 6654 -- may be in the list. If the source is missing, the error will 6655 -- be on the first mention of the source file name. 6656 6657 Name_Loc := Source_Names_Htable.Get 6658 (Project.Source_Names, Name); 6659 6660 if Name_Loc = No_Name_Location then 6661 Name_Loc := 6662 (Name => Name, 6663 Location => Location, 6664 Source => No_Source, 6665 Listed => True, 6666 Found => False); 6667 6668 else 6669 Name_Loc.Listed := True; 6670 end if; 6671 6672 Source_Names_Htable.Set 6673 (Project.Source_Names, Name, Name_Loc); 6674 6675 Current := Element.Next; 6676 end loop; 6677 6678 Has_Explicit_Sources := True; 6679 end; 6680 6681 -- If we have no Source_Files attribute, check the Source_List_File 6682 -- attribute. 6683 6684 elsif not Source_List_File.Default then 6685 6686 -- Source_List_File is the name of the file that contains the source 6687 -- file names. 6688 6689 declare 6690 Source_File_Path_Name : constant String := 6691 Path_Name_Of 6692 (File_Name_Type 6693 (Source_List_File.Value), 6694 Project.Project. 6695 Directory.Display_Name); 6696 6697 begin 6698 Has_Explicit_Sources := True; 6699 6700 if Source_File_Path_Name'Length = 0 then 6701 Err_Vars.Error_Msg_File_1 := 6702 File_Name_Type (Source_List_File.Value); 6703 Error_Msg 6704 (Data.Flags, 6705 "file with sources { does not exist", 6706 Source_List_File.Location, Project.Project); 6707 6708 else 6709 Get_Sources_From_File 6710 (Source_File_Path_Name, Source_List_File.Location, 6711 Project, Data); 6712 end if; 6713 end; 6714 6715 else 6716 -- Neither Source_Files nor Source_List_File has been specified. Find 6717 -- all the files that satisfy the naming scheme in all the source 6718 -- directories. 6719 6720 Has_Explicit_Sources := False; 6721 end if; 6722 6723 -- Remove any exception that is not in the specified list of sources 6724 6725 if Has_Explicit_Sources then 6726 declare 6727 Source : Source_Id; 6728 Iter : Source_Iterator; 6729 NL : Name_Location; 6730 Again : Boolean; 6731 begin 6732 Iter_Loop : 6733 loop 6734 Again := False; 6735 Iter := For_Each_Source (Data.Tree, Project.Project); 6736 6737 Source_Loop : 6738 loop 6739 Source := Prj.Element (Iter); 6740 exit Source_Loop when Source = No_Source; 6741 6742 if Source.Naming_Exception /= No then 6743 NL := Source_Names_Htable.Get 6744 (Project.Source_Names, Source.File); 6745 6746 if NL /= No_Name_Location and then not NL.Listed then 6747 6748 -- Remove the exception 6749 6750 Source_Names_Htable.Set 6751 (Project.Source_Names, 6752 Source.File, 6753 No_Name_Location); 6754 Remove_Source (Data.Tree, Source, No_Source); 6755 6756 if Source.Naming_Exception = Yes then 6757 Error_Msg_Name_1 := Name_Id (Source.File); 6758 Error_Msg 6759 (Data.Flags, 6760 "? unknown source file %%", 6761 NL.Location, 6762 Project.Project); 6763 end if; 6764 6765 Again := True; 6766 exit Source_Loop; 6767 end if; 6768 end if; 6769 6770 Next (Iter); 6771 end loop Source_Loop; 6772 6773 exit Iter_Loop when not Again; 6774 end loop Iter_Loop; 6775 end; 6776 end if; 6777 6778 Search_Directories 6779 (Project, 6780 Data => Data, 6781 For_All_Sources => Sources.Default and then Source_List_File.Default); 6782 6783 -- Check if all exceptions have been found 6784 6785 declare 6786 Source : Source_Id; 6787 Iter : Source_Iterator; 6788 Found : Boolean := False; 6789 6790 begin 6791 Iter := For_Each_Source (Data.Tree, Project.Project); 6792 loop 6793 Source := Prj.Element (Iter); 6794 exit when Source = No_Source; 6795 6796 -- If the full source path is unknown for this source_id, there 6797 -- could be several reasons: 6798 -- * we simply did not find the file itself, this is an error 6799 -- * we have a multi-unit source file. Another Source_Id from 6800 -- the same file has received the full path, so we need to 6801 -- propagate it. 6802 6803 if Source.Path = No_Path_Information then 6804 if Source.Naming_Exception = Yes then 6805 if Source.Unit /= No_Unit_Index then 6806 Found := False; 6807 6808 if Source.Index /= 0 then -- Only multi-unit files 6809 declare 6810 S : Source_Id := 6811 Source_Files_Htable.Get 6812 (Data.Tree.Source_Files_HT, Source.File); 6813 6814 begin 6815 while S /= null loop 6816 if S.Path /= No_Path_Information then 6817 Source.Path := S.Path; 6818 Found := True; 6819 6820 if Current_Verbosity = High then 6821 Debug_Output 6822 ("setting full path for " 6823 & Get_Name_String (Source.File) 6824 & " at" & Source.Index'Img 6825 & " to " 6826 & Get_Name_String (Source.Path.Name)); 6827 end if; 6828 6829 exit; 6830 end if; 6831 6832 S := S.Next_With_File_Name; 6833 end loop; 6834 end; 6835 end if; 6836 6837 if not Found then 6838 Error_Msg_Name_1 := Name_Id (Source.Display_File); 6839 Error_Msg_Name_2 := Source.Unit.Name; 6840 Error_Or_Warning 6841 (Data.Flags, Data.Flags.Missing_Source_Files, 6842 "\source file %% for unit %% not found", 6843 No_Location, Project.Project); 6844 end if; 6845 end if; 6846 6847 if Source.Path = No_Path_Information then 6848 Remove_Source (Data.Tree, Source, No_Source); 6849 end if; 6850 6851 elsif Source.Naming_Exception = Inherited then 6852 Remove_Source (Data.Tree, Source, No_Source); 6853 end if; 6854 end if; 6855 6856 Next (Iter); 6857 end loop; 6858 end; 6859 6860 -- It is an error if a source file name in a source list or in a source 6861 -- list file is not found. 6862 6863 if Has_Explicit_Sources then 6864 declare 6865 NL : Name_Location; 6866 First_Error : Boolean; 6867 6868 begin 6869 NL := Source_Names_Htable.Get_First (Project.Source_Names); 6870 First_Error := True; 6871 while NL /= No_Name_Location loop 6872 if not NL.Found then 6873 Err_Vars.Error_Msg_File_1 := NL.Name; 6874 if First_Error then 6875 Error_Or_Warning 6876 (Data.Flags, Data.Flags.Missing_Source_Files, 6877 "source file { not found", 6878 NL.Location, Project.Project); 6879 First_Error := False; 6880 else 6881 Error_Or_Warning 6882 (Data.Flags, Data.Flags.Missing_Source_Files, 6883 "\source file { not found", 6884 NL.Location, Project.Project); 6885 end if; 6886 end if; 6887 6888 NL := Source_Names_Htable.Get_Next (Project.Source_Names); 6889 end loop; 6890 end; 6891 end if; 6892 end Find_Sources; 6893 6894 ---------------- 6895 -- Initialize -- 6896 ---------------- 6897 6898 procedure Initialize 6899 (Data : out Tree_Processing_Data; 6900 Tree : Project_Tree_Ref; 6901 Node_Tree : Prj.Tree.Project_Node_Tree_Ref; 6902 Flags : Prj.Processing_Flags) 6903 is 6904 begin 6905 Data.Tree := Tree; 6906 Data.Node_Tree := Node_Tree; 6907 Data.Flags := Flags; 6908 end Initialize; 6909 6910 ---------- 6911 -- Free -- 6912 ---------- 6913 6914 procedure Free (Data : in out Tree_Processing_Data) is 6915 pragma Unreferenced (Data); 6916 begin 6917 null; 6918 end Free; 6919 6920 ---------------- 6921 -- Initialize -- 6922 ---------------- 6923 6924 procedure Initialize 6925 (Data : in out Project_Processing_Data; 6926 Project : Project_Id) 6927 is 6928 begin 6929 Data.Project := Project; 6930 end Initialize; 6931 6932 ---------- 6933 -- Free -- 6934 ---------- 6935 6936 procedure Free (Data : in out Project_Processing_Data) is 6937 begin 6938 Source_Names_Htable.Reset (Data.Source_Names); 6939 Unit_Exceptions_Htable.Reset (Data.Unit_Exceptions); 6940 Excluded_Sources_Htable.Reset (Data.Excluded); 6941 end Free; 6942 6943 ------------------------------- 6944 -- Check_File_Naming_Schemes -- 6945 ------------------------------- 6946 6947 procedure Check_File_Naming_Schemes 6948 (Project : Project_Processing_Data; 6949 File_Name : File_Name_Type; 6950 Alternate_Languages : out Language_List; 6951 Language : out Language_Ptr; 6952 Display_Language_Name : out Name_Id; 6953 Unit : out Name_Id; 6954 Lang_Kind : out Language_Kind; 6955 Kind : out Source_Kind) 6956 is 6957 Filename : constant String := Get_Name_String (File_Name); 6958 Config : Language_Config; 6959 Tmp_Lang : Language_Ptr; 6960 6961 Header_File : Boolean := False; 6962 -- True if we found at least one language for which the file is a header 6963 -- In such a case, we search for all possible languages where this is 6964 -- also a header (C and C++ for instance), since the file might be used 6965 -- for several such languages. 6966 6967 procedure Check_File_Based_Lang; 6968 -- Does the naming scheme test for file-based languages. For those, 6969 -- there is no Unit. Just check if the file name has the implementation 6970 -- or, if it is specified, the template suffix of the language. 6971 -- 6972 -- Returns True if the file belongs to the current language and we 6973 -- should stop searching for matching languages. Not that a given header 6974 -- file could belong to several languages (C and C++ for instance). Thus 6975 -- if we found a header we'll check whether it matches other languages. 6976 6977 --------------------------- 6978 -- Check_File_Based_Lang -- 6979 --------------------------- 6980 6981 procedure Check_File_Based_Lang is 6982 begin 6983 if not Header_File 6984 and then Suffix_Matches (Filename, Config.Naming_Data.Body_Suffix) 6985 then 6986 Unit := No_Name; 6987 Kind := Impl; 6988 Language := Tmp_Lang; 6989 6990 Debug_Output 6991 ("implementation of language ", Display_Language_Name); 6992 6993 elsif Suffix_Matches (Filename, Config.Naming_Data.Spec_Suffix) then 6994 Debug_Output 6995 ("header of language ", Display_Language_Name); 6996 6997 if Header_File then 6998 Alternate_Languages := new Language_List_Element' 6999 (Language => Language, 7000 Next => Alternate_Languages); 7001 7002 else 7003 Header_File := True; 7004 Kind := Spec; 7005 Unit := No_Name; 7006 Language := Tmp_Lang; 7007 end if; 7008 end if; 7009 end Check_File_Based_Lang; 7010 7011 -- Start of processing for Check_File_Naming_Schemes 7012 7013 begin 7014 Language := No_Language_Index; 7015 Alternate_Languages := null; 7016 Display_Language_Name := No_Name; 7017 Unit := No_Name; 7018 Lang_Kind := File_Based; 7019 Kind := Spec; 7020 7021 Tmp_Lang := Project.Project.Languages; 7022 while Tmp_Lang /= No_Language_Index loop 7023 if Current_Verbosity = High then 7024 Debug_Output 7025 ("testing language " 7026 & Get_Name_String (Tmp_Lang.Name) 7027 & " Header_File=" & Header_File'Img); 7028 end if; 7029 7030 Display_Language_Name := Tmp_Lang.Display_Name; 7031 Config := Tmp_Lang.Config; 7032 Lang_Kind := Config.Kind; 7033 7034 case Config.Kind is 7035 when File_Based => 7036 Check_File_Based_Lang; 7037 exit when Kind = Impl; 7038 7039 when Unit_Based => 7040 7041 -- We know it belongs to a least a file_based language, no 7042 -- need to check unit-based ones. 7043 7044 if not Header_File then 7045 Compute_Unit_Name 7046 (File_Name => File_Name, 7047 Naming => Config.Naming_Data, 7048 Kind => Kind, 7049 Unit => Unit, 7050 Project => Project); 7051 7052 if Unit /= No_Name then 7053 Language := Tmp_Lang; 7054 exit; 7055 end if; 7056 end if; 7057 end case; 7058 7059 Tmp_Lang := Tmp_Lang.Next; 7060 end loop; 7061 7062 if Language = No_Language_Index then 7063 Debug_Output ("not a source of any language"); 7064 end if; 7065 end Check_File_Naming_Schemes; 7066 7067 ------------------- 7068 -- Override_Kind -- 7069 ------------------- 7070 7071 procedure Override_Kind (Source : Source_Id; Kind : Source_Kind) is 7072 begin 7073 -- If the file was previously already associated with a unit, change it 7074 7075 if Source.Unit /= null 7076 and then Source.Kind in Spec_Or_Body 7077 and then Source.Unit.File_Names (Source.Kind) /= null 7078 then 7079 -- If we had another file referencing the same unit (for instance it 7080 -- was in an extended project), that source file is in fact invisible 7081 -- from now on, and in particular doesn't belong to the same unit. 7082 -- If the source is an inherited naming exception, then it may not 7083 -- really exist: the source potentially replaced is left untouched. 7084 7085 if Source.Unit.File_Names (Source.Kind) /= Source then 7086 Source.Unit.File_Names (Source.Kind).Unit := No_Unit_Index; 7087 end if; 7088 7089 Source.Unit.File_Names (Source.Kind) := null; 7090 end if; 7091 7092 Source.Kind := Kind; 7093 7094 if Current_Verbosity = High and then Source.File /= No_File then 7095 Debug_Output ("override kind for " 7096 & Get_Name_String (Source.File) 7097 & " idx=" & Source.Index'Img 7098 & " kind=" & Source.Kind'Img); 7099 end if; 7100 7101 if Source.Unit /= null then 7102 if Source.Kind = Spec then 7103 Source.Unit.File_Names (Spec) := Source; 7104 else 7105 Source.Unit.File_Names (Impl) := Source; 7106 end if; 7107 end if; 7108 end Override_Kind; 7109 7110 ---------------- 7111 -- Check_File -- 7112 ---------------- 7113 7114 procedure Check_File 7115 (Project : in out Project_Processing_Data; 7116 Data : in out Tree_Processing_Data; 7117 Source_Dir_Rank : Natural; 7118 Path : Path_Name_Type; 7119 Display_Path : Path_Name_Type; 7120 File_Name : File_Name_Type; 7121 Display_File_Name : File_Name_Type; 7122 Locally_Removed : Boolean; 7123 For_All_Sources : Boolean) 7124 is 7125 Name_Loc : Name_Location := 7126 Source_Names_Htable.Get 7127 (Project.Source_Names, File_Name); 7128 Check_Name : Boolean := False; 7129 Alternate_Languages : Language_List; 7130 Language : Language_Ptr; 7131 Source : Source_Id; 7132 Src_Ind : Source_File_Index; 7133 Unit : Name_Id; 7134 Display_Language_Name : Name_Id; 7135 Lang_Kind : Language_Kind; 7136 Kind : Source_Kind := Spec; 7137 7138 begin 7139 if Current_Verbosity = High then 7140 Debug_Increase_Indent 7141 ("checking file (rank=" & Source_Dir_Rank'Img & ")", 7142 Name_Id (Display_Path)); 7143 end if; 7144 7145 if Name_Loc = No_Name_Location then 7146 Check_Name := For_All_Sources; 7147 7148 else 7149 if Name_Loc.Found then 7150 7151 -- Check if it is OK to have the same file name in several 7152 -- source directories. 7153 7154 if Name_Loc.Source /= No_Source 7155 and then Source_Dir_Rank = Name_Loc.Source.Source_Dir_Rank 7156 then 7157 Error_Msg_File_1 := File_Name; 7158 Error_Msg 7159 (Data.Flags, 7160 "{ is found in several source directories", 7161 Name_Loc.Location, Project.Project); 7162 end if; 7163 7164 else 7165 Name_Loc.Found := True; 7166 7167 Source_Names_Htable.Set 7168 (Project.Source_Names, File_Name, Name_Loc); 7169 7170 if Name_Loc.Source = No_Source then 7171 Check_Name := True; 7172 7173 else 7174 -- Set the full path for the source_id (which might have been 7175 -- created when parsing the naming exceptions, and therefore 7176 -- might not have the full path). 7177 -- We only set this for this source_id, but not for other 7178 -- source_id in the same file (case of multi-unit source files) 7179 -- For the latter, they will be set in Find_Sources when we 7180 -- check that all source_id have known full paths. 7181 -- Doing this later saves one htable lookup per file in the 7182 -- common case where the user is not using multi-unit files. 7183 7184 Name_Loc.Source.Path := (Path, Display_Path); 7185 7186 Source_Paths_Htable.Set 7187 (Data.Tree.Source_Paths_HT, Path, Name_Loc.Source); 7188 7189 -- Check if this is a subunit 7190 7191 if Name_Loc.Source.Unit /= No_Unit_Index 7192 and then Name_Loc.Source.Kind = Impl 7193 then 7194 Src_Ind := Sinput.P.Load_Project_File 7195 (Get_Name_String (Display_Path)); 7196 7197 if Sinput.P.Source_File_Is_Subunit (Src_Ind) then 7198 Override_Kind (Name_Loc.Source, Sep); 7199 end if; 7200 end if; 7201 7202 -- If this is an inherited naming exception, make sure that 7203 -- the naming exception it replaces is no longer a source. 7204 7205 if Name_Loc.Source.Naming_Exception = Inherited then 7206 declare 7207 Proj : Project_Id := Name_Loc.Source.Project.Extends; 7208 Iter : Source_Iterator; 7209 Src : Source_Id; 7210 begin 7211 while Proj /= No_Project loop 7212 Iter := For_Each_Source (Data.Tree, Proj); 7213 Src := Prj.Element (Iter); 7214 while Src /= No_Source loop 7215 if Src.File = Name_Loc.Source.File then 7216 Src.Replaced_By := Name_Loc.Source; 7217 exit; 7218 end if; 7219 7220 Next (Iter); 7221 Src := Prj.Element (Iter); 7222 end loop; 7223 7224 Proj := Proj.Extends; 7225 end loop; 7226 end; 7227 7228 if Name_Loc.Source.Unit /= No_Unit_Index then 7229 if Name_Loc.Source.Kind = Spec then 7230 Name_Loc.Source.Unit.File_Names (Spec) := 7231 Name_Loc.Source; 7232 7233 elsif Name_Loc.Source.Kind = Impl then 7234 Name_Loc.Source.Unit.File_Names (Impl) := 7235 Name_Loc.Source; 7236 end if; 7237 7238 Units_Htable.Set 7239 (Data.Tree.Units_HT, 7240 Name_Loc.Source.Unit.Name, 7241 Name_Loc.Source.Unit); 7242 end if; 7243 end if; 7244 end if; 7245 end if; 7246 end if; 7247 7248 if Check_Name then 7249 Check_File_Naming_Schemes 7250 (Project => Project, 7251 File_Name => File_Name, 7252 Alternate_Languages => Alternate_Languages, 7253 Language => Language, 7254 Display_Language_Name => Display_Language_Name, 7255 Unit => Unit, 7256 Lang_Kind => Lang_Kind, 7257 Kind => Kind); 7258 7259 if Language = No_Language_Index then 7260 7261 -- A file name in a list must be a source of a language 7262 7263 if Data.Flags.Error_On_Unknown_Language and then Name_Loc.Found 7264 then 7265 Error_Msg_File_1 := File_Name; 7266 Error_Msg 7267 (Data.Flags, 7268 "language unknown for {", 7269 Name_Loc.Location, Project.Project); 7270 end if; 7271 7272 else 7273 Add_Source 7274 (Id => Source, 7275 Project => Project.Project, 7276 Source_Dir_Rank => Source_Dir_Rank, 7277 Lang_Id => Language, 7278 Kind => Kind, 7279 Data => Data, 7280 Alternate_Languages => Alternate_Languages, 7281 File_Name => File_Name, 7282 Display_File => Display_File_Name, 7283 Unit => Unit, 7284 Locally_Removed => Locally_Removed, 7285 Path => (Path, Display_Path)); 7286 7287 -- If it is a source specified in a list, update the entry in 7288 -- the Source_Names table. 7289 7290 if Name_Loc.Found and then Name_Loc.Source = No_Source then 7291 Name_Loc.Source := Source; 7292 Source_Names_Htable.Set 7293 (Project.Source_Names, File_Name, Name_Loc); 7294 end if; 7295 end if; 7296 end if; 7297 7298 Debug_Decrease_Indent; 7299 end Check_File; 7300 7301 --------------------------------- 7302 -- Expand_Subdirectory_Pattern -- 7303 --------------------------------- 7304 7305 procedure Expand_Subdirectory_Pattern 7306 (Project : Project_Id; 7307 Data : in out Tree_Processing_Data; 7308 Patterns : String_List_Id; 7309 Ignore : String_List_Id; 7310 Search_For : Search_Type; 7311 Resolve_Links : Boolean) 7312 is 7313 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; 7314 7315 package Recursive_Dirs is new GNAT.Dynamic_HTables.Simple_HTable 7316 (Header_Num => Header_Num, 7317 Element => Boolean, 7318 No_Element => False, 7319 Key => Path_Name_Type, 7320 Hash => Hash, 7321 Equal => "="); 7322 -- Hash table stores recursive source directories, to avoid looking 7323 -- several times, and to avoid cycles that may be introduced by symbolic 7324 -- links. 7325 7326 File_Pattern : GNAT.Regexp.Regexp; 7327 -- Pattern to use when matching file names 7328 7329 Visited : Recursive_Dirs.Instance; 7330 7331 procedure Find_Pattern 7332 (Pattern_Id : Name_Id; 7333 Rank : Natural; 7334 Location : Source_Ptr); 7335 -- Find a specific pattern 7336 7337 function Recursive_Find_Dirs 7338 (Path : Path_Information; 7339 Rank : Natural) return Boolean; 7340 -- Search all the subdirectories (recursively) of Path. 7341 -- Return True if at least one file or directory was processed 7342 7343 function Subdirectory_Matches 7344 (Path : Path_Information; 7345 Rank : Natural) return Boolean; 7346 -- Called when a matching directory was found. If the user is in fact 7347 -- searching for files, we then search for those files matching the 7348 -- pattern within the directory. 7349 -- Return True if at least one file or directory was processed 7350 7351 -------------------------- 7352 -- Subdirectory_Matches -- 7353 -------------------------- 7354 7355 function Subdirectory_Matches 7356 (Path : Path_Information; 7357 Rank : Natural) return Boolean 7358 is 7359 Dir : Dir_Type; 7360 Name : String (1 .. 250); 7361 Last : Natural; 7362 Found : Path_Information; 7363 Success : Boolean := False; 7364 7365 begin 7366 case Search_For is 7367 when Search_Directories => 7368 Callback (Path, Rank); 7369 return True; 7370 7371 when Search_Files => 7372 Open (Dir, Get_Name_String (Path.Display_Name)); 7373 loop 7374 Read (Dir, Name, Last); 7375 exit when Last = 0; 7376 7377 if Name (Name'First .. Last) /= "." 7378 and then Name (Name'First .. Last) /= ".." 7379 and then Match (Name (Name'First .. Last), File_Pattern) 7380 then 7381 Get_Name_String (Path.Display_Name); 7382 Add_Str_To_Name_Buffer (Name (Name'First .. Last)); 7383 7384 Found.Display_Name := Name_Find; 7385 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); 7386 Found.Name := Name_Find; 7387 7388 Callback (Found, Rank); 7389 Success := True; 7390 end if; 7391 end loop; 7392 7393 Close (Dir); 7394 7395 return Success; 7396 end case; 7397 end Subdirectory_Matches; 7398 7399 ------------------------- 7400 -- Recursive_Find_Dirs -- 7401 ------------------------- 7402 7403 function Recursive_Find_Dirs 7404 (Path : Path_Information; 7405 Rank : Natural) return Boolean 7406 is 7407 Path_Str : constant String := Get_Name_String (Path.Display_Name); 7408 Dir : Dir_Type; 7409 Name : String (1 .. 250); 7410 Last : Natural; 7411 Success : Boolean := False; 7412 7413 begin 7414 Debug_Output ("looking for subdirs of ", Name_Id (Path.Display_Name)); 7415 7416 if Recursive_Dirs.Get (Visited, Path.Name) then 7417 return Success; 7418 end if; 7419 7420 Recursive_Dirs.Set (Visited, Path.Name, True); 7421 7422 Success := Subdirectory_Matches (Path, Rank) or Success; 7423 7424 Open (Dir, Path_Str); 7425 7426 loop 7427 Read (Dir, Name, Last); 7428 exit when Last = 0; 7429 7430 if Name (1 .. Last) /= "." and then Name (1 .. Last) /= ".." then 7431 declare 7432 Path_Name : constant String := 7433 Normalize_Pathname 7434 (Name => Name (1 .. Last), 7435 Directory => Path_Str, 7436 Resolve_Links => Resolve_Links) 7437 & Directory_Separator; 7438 7439 Path2 : Path_Information; 7440 OK : Boolean := True; 7441 7442 begin 7443 if Is_Directory (Path_Name) then 7444 if Ignore /= Nil_String then 7445 declare 7446 Dir_Name : String := Name (1 .. Last); 7447 List : String_List_Id := Ignore; 7448 7449 begin 7450 Canonical_Case_File_Name (Dir_Name); 7451 7452 while List /= Nil_String loop 7453 Get_Name_String 7454 (Shared.String_Elements.Table (List).Value); 7455 Canonical_Case_File_Name 7456 (Name_Buffer (1 .. Name_Len)); 7457 OK := Name_Buffer (1 .. Name_Len) /= Dir_Name; 7458 exit when not OK; 7459 List := Shared.String_Elements.Table (List).Next; 7460 end loop; 7461 end; 7462 end if; 7463 7464 if OK then 7465 Name_Len := 0; 7466 Add_Str_To_Name_Buffer (Path_Name); 7467 Path2.Display_Name := Name_Find; 7468 7469 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); 7470 Path2.Name := Name_Find; 7471 7472 Success := 7473 Recursive_Find_Dirs (Path2, Rank) or Success; 7474 end if; 7475 end if; 7476 end; 7477 end if; 7478 end loop; 7479 7480 Close (Dir); 7481 7482 return Success; 7483 7484 exception 7485 when Directory_Error => 7486 return Success; 7487 end Recursive_Find_Dirs; 7488 7489 ------------------ 7490 -- Find_Pattern -- 7491 ------------------ 7492 7493 procedure Find_Pattern 7494 (Pattern_Id : Name_Id; 7495 Rank : Natural; 7496 Location : Source_Ptr) 7497 is 7498 Pattern : constant String := Get_Name_String (Pattern_Id); 7499 Pattern_End : Natural := Pattern'Last; 7500 Recursive : Boolean; 7501 Dir : File_Name_Type; 7502 Path_Name : Path_Information; 7503 Dir_Exists : Boolean; 7504 Has_Error : Boolean := False; 7505 Success : Boolean; 7506 7507 begin 7508 Debug_Increase_Indent ("Find_Pattern", Pattern_Id); 7509 7510 -- If we are looking for files, find the pattern for the files 7511 7512 if Search_For = Search_Files then 7513 while Pattern_End >= Pattern'First 7514 and then not Is_Directory_Separator (Pattern (Pattern_End)) 7515 loop 7516 Pattern_End := Pattern_End - 1; 7517 end loop; 7518 7519 if Pattern_End = Pattern'Last then 7520 Err_Vars.Error_Msg_File_1 := File_Name_Type (Pattern_Id); 7521 Error_Or_Warning 7522 (Data.Flags, Data.Flags.Missing_Source_Files, 7523 "Missing file name or pattern in {", Location, Project); 7524 return; 7525 end if; 7526 7527 if Current_Verbosity = High then 7528 Debug_Indent; 7529 Write_Str ("file_pattern="); 7530 Write_Str (Pattern (Pattern_End + 1 .. Pattern'Last)); 7531 Write_Str (" dir_pattern="); 7532 Write_Line (Pattern (Pattern'First .. Pattern_End)); 7533 end if; 7534 7535 File_Pattern := Compile 7536 (Pattern (Pattern_End + 1 .. Pattern'Last), 7537 Glob => True, 7538 Case_Sensitive => File_Names_Case_Sensitive); 7539 7540 -- If we had just "*.gpr", this is equivalent to "./*.gpr" 7541 7542 if Pattern_End > Pattern'First then 7543 Pattern_End := Pattern_End - 1; -- Skip directory separator 7544 end if; 7545 end if; 7546 7547 Recursive := 7548 Pattern_End - 1 >= Pattern'First 7549 and then Pattern (Pattern_End - 1 .. Pattern_End) = "**" 7550 and then 7551 (Pattern_End - 1 = Pattern'First 7552 or else Is_Directory_Separator (Pattern (Pattern_End - 2))); 7553 7554 if Recursive then 7555 Pattern_End := Pattern_End - 2; 7556 if Pattern_End > Pattern'First then 7557 Pattern_End := Pattern_End - 1; -- Skip '/' 7558 end if; 7559 end if; 7560 7561 Name_Len := Pattern_End - Pattern'First + 1; 7562 Name_Buffer (1 .. Name_Len) := Pattern (Pattern'First .. Pattern_End); 7563 Dir := Name_Find; 7564 7565 Locate_Directory 7566 (Project => Project, 7567 Name => Dir, 7568 Path => Path_Name, 7569 Dir_Exists => Dir_Exists, 7570 Data => Data, 7571 Must_Exist => False); 7572 7573 if not Dir_Exists then 7574 Err_Vars.Error_Msg_File_1 := Dir; 7575 Error_Or_Warning 7576 (Data.Flags, Data.Flags.Missing_Source_Files, 7577 "{ is not a valid directory", Location, Project); 7578 Has_Error := Data.Flags.Missing_Source_Files = Error; 7579 end if; 7580 7581 if not Has_Error then 7582 7583 -- Links have been resolved if necessary, and Path_Name 7584 -- always ends with a directory separator. 7585 7586 if Recursive then 7587 Success := Recursive_Find_Dirs (Path_Name, Rank); 7588 else 7589 Success := Subdirectory_Matches (Path_Name, Rank); 7590 end if; 7591 7592 if not Success then 7593 case Search_For is 7594 when Search_Directories => 7595 null; -- Error can't occur 7596 7597 when Search_Files => 7598 Err_Vars.Error_Msg_File_1 := File_Name_Type (Pattern_Id); 7599 Error_Or_Warning 7600 (Data.Flags, Data.Flags.Missing_Source_Files, 7601 "file { not found", Location, Project); 7602 end case; 7603 end if; 7604 end if; 7605 7606 Debug_Decrease_Indent ("done Find_Pattern"); 7607 end Find_Pattern; 7608 7609 -- Local variables 7610 7611 Pattern_Id : String_List_Id := Patterns; 7612 Element : String_Element; 7613 Rank : Natural := 1; 7614 7615 -- Start of processing for Expand_Subdirectory_Pattern 7616 7617 begin 7618 while Pattern_Id /= Nil_String loop 7619 Element := Shared.String_Elements.Table (Pattern_Id); 7620 Find_Pattern (Element.Value, Rank, Element.Location); 7621 Rank := Rank + 1; 7622 Pattern_Id := Element.Next; 7623 end loop; 7624 7625 Recursive_Dirs.Reset (Visited); 7626 end Expand_Subdirectory_Pattern; 7627 7628 ------------------------ 7629 -- Search_Directories -- 7630 ------------------------ 7631 7632 procedure Search_Directories 7633 (Project : in out Project_Processing_Data; 7634 Data : in out Tree_Processing_Data; 7635 For_All_Sources : Boolean) 7636 is 7637 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; 7638 7639 Source_Dir : String_List_Id; 7640 Element : String_Element; 7641 Src_Dir_Rank : Number_List_Index; 7642 Num_Nod : Number_Node; 7643 Dir : Dir_Type; 7644 Name : String (1 .. 1_000); 7645 Last : Natural; 7646 File_Name : File_Name_Type; 7647 Display_File_Name : File_Name_Type; 7648 7649 begin 7650 Debug_Increase_Indent ("looking for sources of", Project.Project.Name); 7651 7652 -- Loop through subdirectories 7653 7654 Src_Dir_Rank := Project.Project.Source_Dir_Ranks; 7655 7656 Source_Dir := Project.Project.Source_Dirs; 7657 while Source_Dir /= Nil_String loop 7658 begin 7659 Num_Nod := Shared.Number_Lists.Table (Src_Dir_Rank); 7660 Element := Shared.String_Elements.Table (Source_Dir); 7661 7662 -- Use Element.Value in this test, not Display_Value, because we 7663 -- want the symbolic links to be resolved when appropriate. 7664 7665 if Element.Value /= No_Name then 7666 declare 7667 Source_Directory : constant String := 7668 Get_Name_String (Element.Value) 7669 & Directory_Separator; 7670 7671 Dir_Last : constant Natural := 7672 Compute_Directory_Last (Source_Directory); 7673 7674 Display_Source_Directory : constant String := 7675 Get_Name_String 7676 (Element.Display_Value) 7677 & Directory_Separator; 7678 -- Display_Source_Directory is to allow us to open a UTF-8 7679 -- encoded directory on Windows. 7680 7681 begin 7682 if Current_Verbosity = High then 7683 Debug_Increase_Indent 7684 ("Source_Dir (node=" & Num_Nod.Number'Img & ") """ 7685 & Source_Directory (Source_Directory'First .. Dir_Last) 7686 & '"'); 7687 end if; 7688 7689 -- We look to every entry in the source directory 7690 7691 Open (Dir, Display_Source_Directory); 7692 7693 loop 7694 Read (Dir, Name, Last); 7695 exit when Last = 0; 7696 7697 -- In fast project loading mode (without -eL), the user 7698 -- guarantees that no directory has a name which is a 7699 -- valid source name, so we can avoid doing a system call 7700 -- here. This provides a very significant speed up on 7701 -- slow file systems (remote files for instance). 7702 7703 if not Opt.Follow_Links_For_Files 7704 or else Is_Regular_File 7705 (Display_Source_Directory & Name (1 .. Last)) 7706 then 7707 Name_Len := Last; 7708 Name_Buffer (1 .. Name_Len) := Name (1 .. Last); 7709 Display_File_Name := Name_Find; 7710 7711 if Osint.File_Names_Case_Sensitive then 7712 File_Name := Display_File_Name; 7713 else 7714 Canonical_Case_File_Name 7715 (Name_Buffer (1 .. Name_Len)); 7716 File_Name := Name_Find; 7717 end if; 7718 7719 declare 7720 Path_Name : constant String := 7721 Normalize_Pathname 7722 (Name (1 .. Last), 7723 Directory => 7724 Source_Directory 7725 (Source_Directory'First .. 7726 Dir_Last), 7727 Resolve_Links => 7728 Opt.Follow_Links_For_Files, 7729 Case_Sensitive => True); 7730 7731 Path : Path_Name_Type; 7732 FF : File_Found := 7733 Excluded_Sources_Htable.Get 7734 (Project.Excluded, File_Name); 7735 To_Remove : Boolean := False; 7736 7737 begin 7738 Name_Len := Path_Name'Length; 7739 Name_Buffer (1 .. Name_Len) := Path_Name; 7740 7741 if Osint.File_Names_Case_Sensitive then 7742 Path := Name_Find; 7743 else 7744 Canonical_Case_File_Name 7745 (Name_Buffer (1 .. Name_Len)); 7746 Path := Name_Find; 7747 end if; 7748 7749 if FF /= No_File_Found then 7750 if not FF.Found then 7751 FF.Found := True; 7752 Excluded_Sources_Htable.Set 7753 (Project.Excluded, File_Name, FF); 7754 7755 Debug_Output 7756 ("excluded source ", 7757 Name_Id (Display_File_Name)); 7758 7759 -- Will mark the file as removed, but we 7760 -- still need to add it to the list: if we 7761 -- don't, the file will not appear in the 7762 -- mapping file and will cause the compiler 7763 -- to fail. 7764 7765 To_Remove := True; 7766 end if; 7767 end if; 7768 7769 -- Preserve the user's original casing and use of 7770 -- links. The display_value (a directory) already 7771 -- ends with a directory separator by construction, 7772 -- so no need to add one. 7773 7774 Get_Name_String (Element.Display_Value); 7775 Get_Name_String_And_Append (Display_File_Name); 7776 7777 Check_File 7778 (Project => Project, 7779 Source_Dir_Rank => Num_Nod.Number, 7780 Data => Data, 7781 Path => Path, 7782 Display_Path => Name_Find, 7783 File_Name => File_Name, 7784 Locally_Removed => To_Remove, 7785 Display_File_Name => Display_File_Name, 7786 For_All_Sources => For_All_Sources); 7787 end; 7788 7789 else 7790 if Current_Verbosity = High then 7791 Debug_Output ("ignore " & Name (1 .. Last)); 7792 end if; 7793 end if; 7794 end loop; 7795 7796 Debug_Decrease_Indent; 7797 Close (Dir); 7798 end; 7799 end if; 7800 7801 exception 7802 when Directory_Error => 7803 null; 7804 end; 7805 7806 Source_Dir := Element.Next; 7807 Src_Dir_Rank := Num_Nod.Next; 7808 end loop; 7809 7810 Debug_Decrease_Indent ("end looking for sources."); 7811 end Search_Directories; 7812 7813 ---------------------------- 7814 -- Load_Naming_Exceptions -- 7815 ---------------------------- 7816 7817 procedure Load_Naming_Exceptions 7818 (Project : in out Project_Processing_Data; 7819 Data : in out Tree_Processing_Data) 7820 is 7821 Source : Source_Id; 7822 Iter : Source_Iterator; 7823 7824 begin 7825 Iter := For_Each_Source (Data.Tree, Project.Project); 7826 loop 7827 Source := Prj.Element (Iter); 7828 exit when Source = No_Source; 7829 7830 -- An excluded file cannot also be an exception file name 7831 7832 if Excluded_Sources_Htable.Get (Project.Excluded, Source.File) /= 7833 No_File_Found 7834 then 7835 Error_Msg_File_1 := Source.File; 7836 Error_Msg 7837 (Data.Flags, 7838 "\{ cannot be both excluded and an exception file name", 7839 No_Location, Project.Project); 7840 end if; 7841 7842 Debug_Output 7843 ("naming exception: adding source file to source_Names: ", 7844 Name_Id (Source.File)); 7845 7846 Source_Names_Htable.Set 7847 (Project.Source_Names, 7848 K => Source.File, 7849 E => Name_Location' 7850 (Name => Source.File, 7851 Location => Source.Location, 7852 Source => Source, 7853 Listed => False, 7854 Found => False)); 7855 7856 -- If this is an Ada exception, record in table Unit_Exceptions 7857 7858 if Source.Unit /= No_Unit_Index then 7859 declare 7860 Unit_Except : Unit_Exception := 7861 Unit_Exceptions_Htable.Get 7862 (Project.Unit_Exceptions, Source.Unit.Name); 7863 7864 begin 7865 Unit_Except.Name := Source.Unit.Name; 7866 7867 if Source.Kind = Spec then 7868 Unit_Except.Spec := Source.File; 7869 else 7870 Unit_Except.Impl := Source.File; 7871 end if; 7872 7873 Unit_Exceptions_Htable.Set 7874 (Project.Unit_Exceptions, Source.Unit.Name, Unit_Except); 7875 end; 7876 end if; 7877 7878 Next (Iter); 7879 end loop; 7880 end Load_Naming_Exceptions; 7881 7882 ---------------------- 7883 -- Look_For_Sources -- 7884 ---------------------- 7885 7886 procedure Look_For_Sources 7887 (Project : in out Project_Processing_Data; 7888 Data : in out Tree_Processing_Data) 7889 is 7890 Object_Files : Object_File_Names_Htable.Instance; 7891 Iter : Source_Iterator; 7892 Src : Source_Id; 7893 7894 procedure Check_Object (Src : Source_Id); 7895 -- Check if object file name of Src is already used in the project tree, 7896 -- and report an error if so. 7897 7898 procedure Check_Object_Files; 7899 -- Check that no two sources of this project have the same object file 7900 7901 procedure Mark_Excluded_Sources; 7902 -- Mark as such the sources that are declared as excluded 7903 7904 procedure Check_Missing_Sources; 7905 -- Check whether one of the languages has no sources, and report an 7906 -- error when appropriate 7907 7908 procedure Get_Sources_From_Source_Info; 7909 -- Get the source information from the tables that were created when a 7910 -- source info file was read. 7911 7912 --------------------------- 7913 -- Check_Missing_Sources -- 7914 --------------------------- 7915 7916 procedure Check_Missing_Sources is 7917 Extending : constant Boolean := 7918 Project.Project.Extends /= No_Project; 7919 Language : Language_Ptr; 7920 Source : Source_Id; 7921 Alt_Lang : Language_List; 7922 Continuation : Boolean := False; 7923 Iter : Source_Iterator; 7924 begin 7925 if not Project.Project.Externally_Built and then not Extending then 7926 Language := Project.Project.Languages; 7927 while Language /= No_Language_Index loop 7928 7929 -- If there are no sources for this language, check if there 7930 -- are sources for which this is an alternate language. 7931 7932 if Language.First_Source = No_Source 7933 and then (Data.Flags.Require_Sources_Other_Lang 7934 or else Language.Name = Name_Ada) 7935 then 7936 Iter := For_Each_Source (In_Tree => Data.Tree, 7937 Project => Project.Project); 7938 Source_Loop : loop 7939 Source := Element (Iter); 7940 exit Source_Loop when Source = No_Source 7941 or else Source.Language = Language; 7942 7943 Alt_Lang := Source.Alternate_Languages; 7944 while Alt_Lang /= null loop 7945 exit Source_Loop when Alt_Lang.Language = Language; 7946 Alt_Lang := Alt_Lang.Next; 7947 end loop; 7948 7949 Next (Iter); 7950 end loop Source_Loop; 7951 7952 if Source = No_Source then 7953 Report_No_Sources 7954 (Project.Project, 7955 Get_Name_String (Language.Display_Name), 7956 Data, 7957 Project.Source_List_File_Location, 7958 Continuation); 7959 Continuation := True; 7960 end if; 7961 end if; 7962 7963 Language := Language.Next; 7964 end loop; 7965 end if; 7966 end Check_Missing_Sources; 7967 7968 ------------------ 7969 -- Check_Object -- 7970 ------------------ 7971 7972 procedure Check_Object (Src : Source_Id) is 7973 Source : Source_Id; 7974 7975 begin 7976 Source := Object_File_Names_Htable.Get (Object_Files, Src.Object); 7977 7978 -- We cannot just check on "Source /= Src", since we might have 7979 -- two different entries for the same file (and since that's 7980 -- the same file it is expected that it has the same object) 7981 7982 if Source /= No_Source 7983 and then Source.Replaced_By = No_Source 7984 and then Source.Path /= Src.Path 7985 and then Source.Index = 0 7986 and then Src.Index = 0 7987 and then Is_Extending (Src.Project, Source.Project) 7988 then 7989 Error_Msg_File_1 := Src.File; 7990 Error_Msg_File_2 := Source.File; 7991 Error_Msg 7992 (Data.Flags, 7993 "\{ and { have the same object file name", 7994 No_Location, Project.Project); 7995 7996 else 7997 Object_File_Names_Htable.Set (Object_Files, Src.Object, Src); 7998 end if; 7999 end Check_Object; 8000 8001 --------------------------- 8002 -- Mark_Excluded_Sources -- 8003 --------------------------- 8004 8005 procedure Mark_Excluded_Sources is 8006 Source : Source_Id := No_Source; 8007 Excluded : File_Found; 8008 Proj : Project_Id; 8009 8010 begin 8011 -- Minor optimization: if there are no excluded files, no need to 8012 -- traverse the list of sources. We cannot however also check whether 8013 -- the existing exceptions have ".Found" set to True (indicating we 8014 -- found them before) because we need to do some final processing on 8015 -- them in any case. 8016 8017 if Excluded_Sources_Htable.Get_First (Project.Excluded) /= 8018 No_File_Found 8019 then 8020 Proj := Project.Project; 8021 while Proj /= No_Project loop 8022 Iter := For_Each_Source (Data.Tree, Proj); 8023 while Prj.Element (Iter) /= No_Source loop 8024 Source := Prj.Element (Iter); 8025 Excluded := Excluded_Sources_Htable.Get 8026 (Project.Excluded, Source.File); 8027 8028 if Excluded /= No_File_Found then 8029 Source.In_Interfaces := False; 8030 Source.Locally_Removed := True; 8031 8032 if Proj = Project.Project then 8033 Source.Suppressed := True; 8034 end if; 8035 8036 if Current_Verbosity = High then 8037 Debug_Indent; 8038 Write_Str ("removing file "); 8039 Write_Line 8040 (Get_Name_String (Excluded.File) 8041 & " " & Get_Name_String (Source.Project.Name)); 8042 end if; 8043 8044 Excluded_Sources_Htable.Remove 8045 (Project.Excluded, Source.File); 8046 end if; 8047 8048 Next (Iter); 8049 end loop; 8050 8051 Proj := Proj.Extends; 8052 end loop; 8053 end if; 8054 8055 -- If we have any excluded element left, that means we did not find 8056 -- the source file 8057 8058 Excluded := Excluded_Sources_Htable.Get_First (Project.Excluded); 8059 while Excluded /= No_File_Found loop 8060 if not Excluded.Found then 8061 8062 -- Check if the file belongs to another imported project to 8063 -- provide a better error message. 8064 8065 Src := Find_Source 8066 (In_Tree => Data.Tree, 8067 Project => Project.Project, 8068 In_Imported_Only => True, 8069 Base_Name => Excluded.File); 8070 8071 Err_Vars.Error_Msg_File_1 := Excluded.File; 8072 8073 if Src = No_Source then 8074 if Excluded.Excl_File = No_File then 8075 Error_Msg 8076 (Data.Flags, 8077 "unknown file {", Excluded.Location, Project.Project); 8078 8079 else 8080 Error_Msg 8081 (Data.Flags, 8082 "in " & 8083 Get_Name_String (Excluded.Excl_File) & ":" & 8084 No_Space_Img (Excluded.Excl_Line) & 8085 ": unknown file {", Excluded.Location, Project.Project); 8086 end if; 8087 8088 else 8089 if Excluded.Excl_File = No_File then 8090 Error_Msg 8091 (Data.Flags, 8092 "cannot remove a source from an imported project: {", 8093 Excluded.Location, Project.Project); 8094 8095 else 8096 Error_Msg 8097 (Data.Flags, 8098 "in " & 8099 Get_Name_String (Excluded.Excl_File) & ":" & 8100 No_Space_Img (Excluded.Excl_Line) & 8101 ": cannot remove a source from an imported project: {", 8102 Excluded.Location, Project.Project); 8103 end if; 8104 end if; 8105 end if; 8106 8107 Excluded := Excluded_Sources_Htable.Get_Next (Project.Excluded); 8108 end loop; 8109 end Mark_Excluded_Sources; 8110 8111 ------------------------ 8112 -- Check_Object_Files -- 8113 ------------------------ 8114 8115 procedure Check_Object_Files is 8116 Iter : Source_Iterator; 8117 Src_Id : Source_Id; 8118 Src_Ind : Source_File_Index; 8119 8120 begin 8121 Iter := For_Each_Source (Data.Tree); 8122 loop 8123 Src_Id := Prj.Element (Iter); 8124 exit when Src_Id = No_Source; 8125 8126 if Is_Compilable (Src_Id) 8127 and then Src_Id.Language.Config.Object_Generated 8128 and then Is_Extending (Project.Project, Src_Id.Project) 8129 then 8130 if Src_Id.Unit = No_Unit_Index then 8131 if Src_Id.Kind = Impl then 8132 Check_Object (Src_Id); 8133 end if; 8134 8135 else 8136 case Src_Id.Kind is 8137 when Spec => 8138 if Other_Part (Src_Id) = No_Source then 8139 Check_Object (Src_Id); 8140 end if; 8141 8142 when Sep => 8143 null; 8144 8145 when Impl => 8146 if Other_Part (Src_Id) /= No_Source then 8147 Check_Object (Src_Id); 8148 8149 else 8150 -- Check if it is a subunit 8151 8152 Src_Ind := 8153 Sinput.P.Load_Project_File 8154 (Get_Name_String (Src_Id.Path.Display_Name)); 8155 8156 if Sinput.P.Source_File_Is_Subunit (Src_Ind) then 8157 Override_Kind (Src_Id, Sep); 8158 else 8159 Check_Object (Src_Id); 8160 end if; 8161 end if; 8162 end case; 8163 end if; 8164 end if; 8165 8166 Next (Iter); 8167 end loop; 8168 end Check_Object_Files; 8169 8170 ---------------------------------- 8171 -- Get_Sources_From_Source_Info -- 8172 ---------------------------------- 8173 8174 procedure Get_Sources_From_Source_Info is 8175 Iter : Source_Info_Iterator; 8176 Src : Source_Info; 8177 Id : Source_Id; 8178 Lang_Id : Language_Ptr; 8179 8180 begin 8181 Initialize (Iter, Project.Project.Name); 8182 8183 loop 8184 Src := Source_Info_Of (Iter); 8185 8186 exit when Src = No_Source_Info; 8187 8188 Id := new Source_Data; 8189 8190 Id.Project := Project.Project; 8191 8192 Lang_Id := Project.Project.Languages; 8193 while Lang_Id /= No_Language_Index 8194 and then Lang_Id.Name /= Src.Language 8195 loop 8196 Lang_Id := Lang_Id.Next; 8197 end loop; 8198 8199 if Lang_Id = No_Language_Index then 8200 Prj.Com.Fail 8201 ("unknown language " & 8202 Get_Name_String (Src.Language) & 8203 " for project " & 8204 Get_Name_String (Src.Project) & 8205 " in source info file"); 8206 end if; 8207 8208 Id.Language := Lang_Id; 8209 Id.Kind := Src.Kind; 8210 Id.Index := Src.Index; 8211 8212 Id.Path := 8213 (Path_Name_Type (Src.Display_Path_Name), 8214 Path_Name_Type (Src.Path_Name)); 8215 8216 Name_Len := 0; 8217 Add_Str_To_Name_Buffer 8218 (Directories.Simple_Name (Get_Name_String (Src.Path_Name))); 8219 Id.File := Name_Find; 8220 8221 Id.Next_With_File_Name := 8222 Source_Files_Htable.Get (Data.Tree.Source_Files_HT, Id.File); 8223 Source_Files_Htable.Set (Data.Tree.Source_Files_HT, Id.File, Id); 8224 8225 Name_Len := 0; 8226 Add_Str_To_Name_Buffer 8227 (Directories.Simple_Name 8228 (Get_Name_String (Src.Display_Path_Name))); 8229 Id.Display_File := Name_Find; 8230 8231 Id.Dep_Name := 8232 Dependency_Name (Id.File, Id.Language.Config.Dependency_Kind); 8233 Id.Naming_Exception := Src.Naming_Exception; 8234 Id.Object := 8235 Object_Name (Id.File, Id.Language.Config.Object_File_Suffix); 8236 Id.Switches := Switches_Name (Id.File); 8237 8238 -- Add the source id to the Unit_Sources_HT hash table, if the 8239 -- unit name is not null. 8240 8241 if Src.Kind /= Sep and then Src.Unit_Name /= No_Name then 8242 declare 8243 UData : Unit_Index := 8244 Units_Htable.Get (Data.Tree.Units_HT, Src.Unit_Name); 8245 begin 8246 if UData = No_Unit_Index then 8247 UData := new Unit_Data; 8248 UData.Name := Src.Unit_Name; 8249 Units_Htable.Set 8250 (Data.Tree.Units_HT, Src.Unit_Name, UData); 8251 end if; 8252 8253 Id.Unit := UData; 8254 end; 8255 8256 -- Note that this updates Unit information as well 8257 8258 Override_Kind (Id, Id.Kind); 8259 end if; 8260 8261 if Src.Index /= 0 then 8262 Project.Project.Has_Multi_Unit_Sources := True; 8263 end if; 8264 8265 -- Add the source to the language list 8266 8267 Id.Next_In_Lang := Id.Language.First_Source; 8268 Id.Language.First_Source := Id; 8269 8270 Next (Iter); 8271 end loop; 8272 end Get_Sources_From_Source_Info; 8273 8274 -- Start of processing for Look_For_Sources 8275 8276 begin 8277 if Data.Tree.Source_Info_File_Exists then 8278 Get_Sources_From_Source_Info; 8279 8280 else 8281 if Project.Project.Source_Dirs /= Nil_String then 8282 Find_Excluded_Sources (Project, Data); 8283 8284 if Project.Project.Languages /= No_Language_Index then 8285 Load_Naming_Exceptions (Project, Data); 8286 Find_Sources (Project, Data); 8287 Mark_Excluded_Sources; 8288 Check_Object_Files; 8289 Check_Missing_Sources; 8290 end if; 8291 end if; 8292 8293 Object_File_Names_Htable.Reset (Object_Files); 8294 end if; 8295 end Look_For_Sources; 8296 8297 ------------------ 8298 -- Path_Name_Of -- 8299 ------------------ 8300 8301 function Path_Name_Of 8302 (File_Name : File_Name_Type; 8303 Directory : Path_Name_Type) return String 8304 is 8305 Result : String_Access; 8306 The_Directory : constant String := Get_Name_String (Directory); 8307 8308 begin 8309 Debug_Output ("Path_Name_Of file name=", Name_Id (File_Name)); 8310 Debug_Output ("Path_Name_Of directory=", Name_Id (Directory)); 8311 Get_Name_String (File_Name); 8312 Result := 8313 Locate_Regular_File 8314 (File_Name => Name_Buffer (1 .. Name_Len), 8315 Path => The_Directory); 8316 8317 if Result = null then 8318 return ""; 8319 else 8320 declare 8321 R : constant String := Result.all; 8322 begin 8323 Free (Result); 8324 return R; 8325 end; 8326 end if; 8327 end Path_Name_Of; 8328 8329 ------------------- 8330 -- Remove_Source -- 8331 ------------------- 8332 8333 procedure Remove_Source 8334 (Tree : Project_Tree_Ref; 8335 Id : Source_Id; 8336 Replaced_By : Source_Id) 8337 is 8338 Source : Source_Id; 8339 8340 begin 8341 if Current_Verbosity = High then 8342 Debug_Indent; 8343 Write_Str ("removing source "); 8344 Write_Str (Get_Name_String (Id.File)); 8345 8346 if Id.Index /= 0 then 8347 Write_Str (" at" & Id.Index'Img); 8348 end if; 8349 8350 Write_Eol; 8351 end if; 8352 8353 if Replaced_By /= No_Source then 8354 Id.Replaced_By := Replaced_By; 8355 Replaced_By.Declared_In_Interfaces := Id.Declared_In_Interfaces; 8356 8357 if Id.File /= Replaced_By.File then 8358 declare 8359 Replacement : constant File_Name_Type := 8360 Replaced_Source_HTable.Get 8361 (Tree.Replaced_Sources, Id.File); 8362 8363 begin 8364 Replaced_Source_HTable.Set 8365 (Tree.Replaced_Sources, Id.File, Replaced_By.File); 8366 8367 if Replacement = No_File then 8368 Tree.Replaced_Source_Number := 8369 Tree.Replaced_Source_Number + 1; 8370 end if; 8371 end; 8372 end if; 8373 end if; 8374 8375 Id.In_Interfaces := False; 8376 Id.Locally_Removed := True; 8377 8378 -- ??? Should we remove the source from the unit ? The file is not used, 8379 -- so probably should not be referenced from the unit. On the other hand 8380 -- it might give useful additional info 8381 -- if Id.Unit /= null then 8382 -- Id.Unit.File_Names (Id.Kind) := null; 8383 -- end if; 8384 8385 Source := Id.Language.First_Source; 8386 8387 if Source = Id then 8388 Id.Language.First_Source := Id.Next_In_Lang; 8389 8390 else 8391 while Source.Next_In_Lang /= Id loop 8392 Source := Source.Next_In_Lang; 8393 end loop; 8394 8395 Source.Next_In_Lang := Id.Next_In_Lang; 8396 end if; 8397 end Remove_Source; 8398 8399 ----------------------- 8400 -- Report_No_Sources -- 8401 ----------------------- 8402 8403 procedure Report_No_Sources 8404 (Project : Project_Id; 8405 Lang_Name : String; 8406 Data : Tree_Processing_Data; 8407 Location : Source_Ptr; 8408 Continuation : Boolean := False) 8409 is 8410 begin 8411 case Data.Flags.When_No_Sources is 8412 when Silent => 8413 null; 8414 8415 when Warning | Error => 8416 declare 8417 Msg : constant String := 8418 "<there are no " 8419 & Lang_Name & " sources in this project"; 8420 8421 begin 8422 Error_Msg_Warn := Data.Flags.When_No_Sources = Warning; 8423 8424 if Continuation then 8425 Error_Msg (Data.Flags, "\" & Msg, Location, Project); 8426 else 8427 Error_Msg (Data.Flags, Msg, Location, Project); 8428 end if; 8429 end; 8430 end case; 8431 end Report_No_Sources; 8432 8433 ---------------------- 8434 -- Show_Source_Dirs -- 8435 ---------------------- 8436 8437 procedure Show_Source_Dirs 8438 (Project : Project_Id; 8439 Shared : Shared_Project_Tree_Data_Access) 8440 is 8441 Current : String_List_Id; 8442 Element : String_Element; 8443 8444 begin 8445 if Project.Source_Dirs = Nil_String then 8446 Debug_Output ("no Source_Dirs"); 8447 else 8448 Debug_Increase_Indent ("Source_Dirs:"); 8449 8450 Current := Project.Source_Dirs; 8451 while Current /= Nil_String loop 8452 Element := Shared.String_Elements.Table (Current); 8453 Debug_Output (Get_Name_String (Element.Display_Value)); 8454 Current := Element.Next; 8455 end loop; 8456 8457 Debug_Decrease_Indent ("end Source_Dirs."); 8458 end if; 8459 end Show_Source_Dirs; 8460 8461 --------------------------- 8462 -- Process_Naming_Scheme -- 8463 --------------------------- 8464 8465 procedure Process_Naming_Scheme 8466 (Tree : Project_Tree_Ref; 8467 Root_Project : Project_Id; 8468 Node_Tree : Prj.Tree.Project_Node_Tree_Ref; 8469 Flags : Processing_Flags) 8470 is 8471 8472 procedure Check 8473 (Project : Project_Id; 8474 In_Aggregate_Lib : Boolean; 8475 Data : in out Tree_Processing_Data); 8476 -- Process the naming scheme for a single project 8477 8478 procedure Recursive_Check 8479 (Project : Project_Id; 8480 Prj_Tree : Project_Tree_Ref; 8481 Context : Project_Context; 8482 Data : in out Tree_Processing_Data); 8483 -- Check_Naming_Scheme for the project 8484 8485 ----------- 8486 -- Check -- 8487 ----------- 8488 8489 procedure Check 8490 (Project : Project_Id; 8491 In_Aggregate_Lib : Boolean; 8492 Data : in out Tree_Processing_Data) 8493 is 8494 procedure Check_Aggregated; 8495 -- Check aggregated projects which should not be externally built 8496 8497 ---------------------- 8498 -- Check_Aggregated -- 8499 ---------------------- 8500 8501 procedure Check_Aggregated is 8502 L : Aggregated_Project_List; 8503 8504 begin 8505 -- Check that aggregated projects are not externally built 8506 8507 L := Project.Aggregated_Projects; 8508 while L /= null loop 8509 declare 8510 Var : constant Prj.Variable_Value := 8511 Prj.Util.Value_Of 8512 (Snames.Name_Externally_Built, 8513 L.Project.Decl.Attributes, 8514 Data.Tree.Shared); 8515 begin 8516 if not Var.Default then 8517 Error_Msg_Name_1 := L.Project.Display_Name; 8518 Error_Msg 8519 (Data.Flags, 8520 "cannot aggregate externally built project %%", 8521 Var.Location, Project); 8522 end if; 8523 end; 8524 8525 L := L.Next; 8526 end loop; 8527 end Check_Aggregated; 8528 8529 -- Local Variables 8530 8531 Shared : constant Shared_Project_Tree_Data_Access := 8532 Data.Tree.Shared; 8533 Prj_Data : Project_Processing_Data; 8534 8535 -- Start of processing for Check 8536 8537 begin 8538 Debug_Increase_Indent ("check", Project.Name); 8539 8540 Initialize (Prj_Data, Project); 8541 8542 Check_If_Externally_Built (Project, Data); 8543 8544 case Project.Qualifier is 8545 when Aggregate => 8546 Check_Aggregated; 8547 8548 when Aggregate_Library => 8549 Check_Aggregated; 8550 8551 if Project.Object_Directory = No_Path_Information then 8552 Project.Object_Directory := Project.Directory; 8553 end if; 8554 8555 when others => 8556 Get_Directories (Project, Data); 8557 Check_Programming_Languages (Project, Data); 8558 8559 if Current_Verbosity = High then 8560 Show_Source_Dirs (Project, Shared); 8561 end if; 8562 8563 if Project.Qualifier = Abstract_Project then 8564 Check_Abstract_Project (Project, Data); 8565 end if; 8566 end case; 8567 8568 -- Check configuration. Must be done for gnatmake (even though no 8569 -- user configuration file was provided) since the default config we 8570 -- generate indicates whether libraries are supported for instance. 8571 8572 Check_Configuration (Project, Data); 8573 8574 if Project.Qualifier /= Aggregate then 8575 Check_Library_Attributes (Project, Data); 8576 Check_Package_Naming (Project, Data); 8577 8578 -- An aggregate library has no source, no need to look for them 8579 8580 if Project.Qualifier /= Aggregate_Library then 8581 Look_For_Sources (Prj_Data, Data); 8582 end if; 8583 8584 Check_Interfaces (Project, Data); 8585 8586 -- If this library is part of an aggregated library don't check it 8587 -- as it has no sources by itself and so interface won't be found. 8588 8589 if Project.Library and not In_Aggregate_Lib then 8590 Check_Stand_Alone_Library (Project, Data); 8591 end if; 8592 8593 Get_Mains (Project, Data); 8594 end if; 8595 8596 Free (Prj_Data); 8597 8598 Debug_Decrease_Indent ("done check"); 8599 end Check; 8600 8601 --------------------- 8602 -- Recursive_Check -- 8603 --------------------- 8604 8605 procedure Recursive_Check 8606 (Project : Project_Id; 8607 Prj_Tree : Project_Tree_Ref; 8608 Context : Project_Context; 8609 Data : in out Tree_Processing_Data) 8610 is 8611 begin 8612 if Current_Verbosity = High then 8613 Debug_Increase_Indent 8614 ("Processing_Naming_Scheme for project", Project.Name); 8615 end if; 8616 8617 Data.Tree := Prj_Tree; 8618 Data.In_Aggregate_Lib := Context.In_Aggregate_Lib; 8619 8620 Check (Project, Context.In_Aggregate_Lib, Data); 8621 8622 if Current_Verbosity = High then 8623 Debug_Decrease_Indent ("done Processing_Naming_Scheme"); 8624 end if; 8625 end Recursive_Check; 8626 8627 procedure Check_All_Projects is new For_Every_Project_Imported_Context 8628 (Tree_Processing_Data, Recursive_Check); 8629 -- Comment required??? 8630 8631 -- Local Variables 8632 8633 Data : Tree_Processing_Data; 8634 8635 -- Start of processing for Process_Naming_Scheme 8636 8637 begin 8638 Lib_Data_Table.Init; 8639 Initialize (Data, Tree => Tree, Node_Tree => Node_Tree, Flags => Flags); 8640 Check_All_Projects (Root_Project, Tree, Data, Imported_First => True); 8641 Free (Data); 8642 8643 -- Adjust language configs for projects that are extended 8644 8645 declare 8646 List : Project_List; 8647 Proj : Project_Id; 8648 Exte : Project_Id; 8649 Lang : Language_Ptr; 8650 Elng : Language_Ptr; 8651 8652 begin 8653 List := Tree.Projects; 8654 while List /= null loop 8655 Proj := List.Project; 8656 8657 Exte := Proj; 8658 while Exte.Extended_By /= No_Project loop 8659 Exte := Exte.Extended_By; 8660 end loop; 8661 8662 if Exte /= Proj then 8663 Lang := Proj.Languages; 8664 8665 if Lang /= No_Language_Index then 8666 loop 8667 Elng := Get_Language_From_Name 8668 (Exte, Get_Name_String (Lang.Name)); 8669 exit when Elng /= No_Language_Index; 8670 Exte := Exte.Extends; 8671 end loop; 8672 8673 if Elng /= Lang then 8674 Lang.Config := Elng.Config; 8675 end if; 8676 end if; 8677 end if; 8678 8679 List := List.Next; 8680 end loop; 8681 end; 8682 end Process_Naming_Scheme; 8683 8684end Prj.Nmsc; 8685