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