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