gcc/ada/prj-env.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              P R J . E N V                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2001-2007, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Fmap;
  27 with Opt;
  28 with Osint;    use Osint;
  29 with Output;   use Output;
  30 with Prj.Com;  use Prj.Com;
  31 with Tempdir;
  32
  33 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
  34
  35 package body Prj.Env is
  36
  37    Current_Source_Path_File : Path_Name_Type := No_Path;
  38    --  Current value of project source path file env var.
  39    --  Used to avoid setting the env var to the same value.
  40
  41    Current_Object_Path_File : Path_Name_Type := No_Path;
  42    --  Current value of project object path file env var.
  43    --  Used to avoid setting the env var to the same value.
  44
  45    Ada_Path_Buffer : String_Access := new String (1 .. 1024);
  46    --  A buffer where values for ADA_INCLUDE_PATH
  47    --  and ADA_OBJECTS_PATH are stored.
  48
  49    Ada_Path_Length : Natural := 0;
  50    --  Index of the last valid character in Ada_Path_Buffer
  51
  52    Ada_Prj_Include_File_Set : Boolean := False;
  53    Ada_Prj_Objects_File_Set : Boolean := False;
  54    --  These flags are set to True when the corresponding environment variables
  55    --  are set and are used to give these environment variables an empty string
  56    --  value at the end of the program. This has no practical effect on most
  57    --  platforms, except on VMS where the logical names are deassigned, thus
  58    --  avoiding the pollution of the environment of the caller.
  59
  60    Default_Naming : constant Naming_Id := Naming_Table.First;
  61
  62    Fill_Mapping_File : Boolean := True;
  63
  64    type Project_Flags is array (Project_Id range <>) of Boolean;
  65    --  A Boolean array type used in Create_Mapping_File to select the projects
  66    --  in the closure of a specific project.
  67
  68    -----------------------
  69    -- Local Subprograms --
  70    -----------------------
  71
  72    function Body_Path_Name_Of
  73      (Unit    : Unit_Index;
  74       In_Tree : Project_Tree_Ref) return String;
  75    --  Returns the path name of the body of a unit.
  76    --  Compute it first, if necessary.
  77
  78    function Spec_Path_Name_Of
  79      (Unit    : Unit_Index;
  80       In_Tree : Project_Tree_Ref) return String;
  81    --  Returns the path name of the spec of a unit.
  82    --  Compute it first, if necessary.
  83
  84    procedure Add_To_Path
  85      (Source_Dirs : String_List_Id;
  86       In_Tree     : Project_Tree_Ref);
  87    --  Add to Ada_Path_Buffer all the source directories in string list
  88    --  Source_Dirs, if any. Increment Ada_Path_Length.
  89
  90    procedure Add_To_Path (Dir : String);
  91    --  If Dir is not already in the global variable Ada_Path_Buffer, add it.
  92    --  Increment Ada_Path_Length.
  93    --  If Ada_Path_Length /= 0, prepend a Path_Separator character to
  94    --  Path.
  95
  96    procedure Add_To_Source_Path
  97      (Source_Dirs : String_List_Id; In_Tree : Project_Tree_Ref);
  98    --  Add to Ada_Path_B all the source directories in string list
  99    --  Source_Dirs, if any. Increment Ada_Path_Length.
 100
 101    procedure Add_To_Object_Path
 102      (Object_Dir : Path_Name_Type;
 103       In_Tree    : Project_Tree_Ref);
 104    --  Add Object_Dir to object path table. Make sure it is not duplicate
 105    --  and it is the last one in the current table.
 106
 107    function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean;
 108    --  Return True if there is at least one ALI file in the directory Dir
 109
 110    procedure Set_Path_File_Var (Name : String; Value : String);
 111    --  Call Setenv, after calling To_Host_File_Spec
 112
 113    function Ultimate_Extension_Of
 114      (Project : Project_Id;
 115       In_Tree : Project_Tree_Ref) return Project_Id;
 116    --  Return a project that is either Project or an extended ancestor of
 117    --  Project that itself is not extended.
 118
 119    ----------------------
 120    -- Ada_Include_Path --
 121    ----------------------
 122
 123    function Ada_Include_Path
 124      (Project : Project_Id;
 125       In_Tree : Project_Tree_Ref) return String_Access is
 126
 127       procedure Add (Project : Project_Id);
 128       --  Add all the source directories of a project to the path only if
 129       --  this project has not been visited. Calls itself recursively for
 130       --  projects being extended, and imported projects. Adds the project
 131       --  to the list Seen if this is the call to Add for this project.
 132
 133       ---------
 134       -- Add --
 135       ---------
 136
 137       procedure Add (Project : Project_Id) is
 138       begin
 139          --  If Seen is empty, then the project cannot have been visited
 140
 141          if not In_Tree.Projects.Table (Project).Seen then
 142             In_Tree.Projects.Table (Project).Seen := True;
 143
 144             declare
 145                Data : constant Project_Data :=
 146                         In_Tree.Projects.Table (Project);
 147                List : Project_List := Data.Imported_Projects;
 148
 149             begin
 150                --  Add to path all source directories of this project
 151
 152                Add_To_Path (Data.Source_Dirs, In_Tree);
 153
 154                --  Call Add to the project being extended, if any
 155
 156                if Data.Extends /= No_Project then
 157                   Add (Data.Extends);
 158                end if;
 159
 160                --  Call Add for each imported project, if any
 161
 162                while List /= Empty_Project_List loop
 163                   Add
 164                     (In_Tree.Project_Lists.Table (List).Project);
 165                   List := In_Tree.Project_Lists.Table (List).Next;
 166                end loop;
 167             end;
 168          end if;
 169       end Add;
 170
 171    --  Start of processing for Ada_Include_Path
 172
 173    begin
 174       --  If it is the first time we call this function for
 175       --  this project, compute the source path
 176
 177       if
 178         In_Tree.Projects.Table (Project).Ada_Include_Path = null
 179       then
 180          Ada_Path_Length := 0;
 181
 182          for Index in Project_Table.First ..
 183                       Project_Table.Last (In_Tree.Projects)
 184          loop
 185             In_Tree.Projects.Table (Index).Seen := False;
 186          end loop;
 187
 188          Add (Project);
 189          In_Tree.Projects.Table (Project).Ada_Include_Path :=
 190            new String'(Ada_Path_Buffer (1 .. Ada_Path_Length));
 191       end if;
 192
 193       return In_Tree.Projects.Table (Project).Ada_Include_Path;
 194    end Ada_Include_Path;
 195
 196    ----------------------
 197    -- Ada_Include_Path --
 198    ----------------------
 199
 200    function Ada_Include_Path
 201      (Project   : Project_Id;
 202       In_Tree   : Project_Tree_Ref;
 203       Recursive : Boolean) return String
 204    is
 205    begin
 206       if Recursive then
 207          return Ada_Include_Path (Project, In_Tree).all;
 208       else
 209          Ada_Path_Length := 0;
 210          Add_To_Path
 211            (In_Tree.Projects.Table (Project).Source_Dirs, In_Tree);
 212          return Ada_Path_Buffer (1 .. Ada_Path_Length);
 213       end if;
 214    end Ada_Include_Path;
 215
 216    ----------------------
 217    -- Ada_Objects_Path --
 218    ----------------------
 219
 220    function Ada_Objects_Path
 221      (Project             : Project_Id;
 222       In_Tree             : Project_Tree_Ref;
 223       Including_Libraries : Boolean := True) return String_Access
 224    is
 225       procedure Add (Project : Project_Id);
 226       --  Add all the object directories of a project to the path only if
 227       --  this project has not been visited. Calls itself recursively for
 228       --  projects being extended, and imported projects. Adds the project
 229       --  to the list Seen if this is the first call to Add for this project.
 230
 231       ---------
 232       -- Add --
 233       ---------
 234
 235       procedure Add (Project : Project_Id) is
 236       begin
 237          --  If this project has not been seen yet
 238
 239          if not In_Tree.Projects.Table (Project).Seen then
 240             In_Tree.Projects.Table (Project).Seen := True;
 241
 242             declare
 243                Data : constant Project_Data :=
 244                  In_Tree.Projects.Table (Project);
 245                List : Project_List := Data.Imported_Projects;
 246
 247             begin
 248                --  Add to path the object directory of this project
 249                --  except if we don't include library project and
 250                --  this is a library project.
 251
 252                if (Data.Library and then Including_Libraries)
 253                  or else
 254                  (Data.Object_Directory /= No_Path
 255                    and then
 256                    (not Including_Libraries or else not Data.Library))
 257                then
 258                   --  For a library project, add the library directory,
 259                   --  if there is no object directory or if it contains ALI
 260                   --  files; otherwise add the object directory.
 261
 262                   if Data.Library then
 263                      if Data.Object_Directory = No_Path
 264                        or else
 265                          Contains_ALI_Files (Data.Library_ALI_Dir)
 266                      then
 267                         Add_To_Path (Get_Name_String (Data.Library_ALI_Dir));
 268                      else
 269                         Add_To_Path (Get_Name_String (Data.Object_Directory));
 270                      end if;
 271
 272                   else
 273                      --  For a non library project, add the object directory
 274
 275                      Add_To_Path (Get_Name_String (Data.Object_Directory));
 276                   end if;
 277                end if;
 278
 279                --  Call Add to the project being extended, if any
 280
 281                if Data.Extends /= No_Project then
 282                   Add (Data.Extends);
 283                end if;
 284
 285                --  Call Add for each imported project, if any
 286
 287                while List /= Empty_Project_List loop
 288                   Add
 289                     (In_Tree.Project_Lists.Table (List).Project);
 290                   List := In_Tree.Project_Lists.Table (List).Next;
 291                end loop;
 292             end;
 293
 294          end if;
 295       end Add;
 296
 297    --  Start of processing for Ada_Objects_Path
 298
 299    begin
 300       --  If it is the first time we call this function for
 301       --  this project, compute the objects path
 302
 303       if
 304         In_Tree.Projects.Table (Project).Ada_Objects_Path = null
 305       then
 306          Ada_Path_Length := 0;
 307
 308          for Index in Project_Table.First ..
 309                       Project_Table.Last (In_Tree.Projects)
 310          loop
 311             In_Tree.Projects.Table (Index).Seen := False;
 312          end loop;
 313
 314          Add (Project);
 315          In_Tree.Projects.Table (Project).Ada_Objects_Path :=
 316            new String'(Ada_Path_Buffer (1 .. Ada_Path_Length));
 317       end if;
 318
 319       return In_Tree.Projects.Table (Project).Ada_Objects_Path;
 320    end Ada_Objects_Path;
 321
 322    ------------------------
 323    -- Add_To_Object_Path --
 324    ------------------------
 325
 326    procedure Add_To_Object_Path
 327      (Object_Dir : Path_Name_Type; In_Tree : Project_Tree_Ref)
 328    is
 329    begin
 330       --  Check if the directory is already in the table
 331
 332       for Index in Object_Path_Table.First ..
 333                    Object_Path_Table.Last (In_Tree.Private_Part.Object_Paths)
 334       loop
 335
 336          --  If it is, remove it, and add it as the last one
 337
 338          if In_Tree.Private_Part.Object_Paths.Table (Index) = Object_Dir then
 339             for Index2 in Index + 1 ..
 340                           Object_Path_Table.Last
 341                             (In_Tree.Private_Part.Object_Paths)
 342             loop
 343                In_Tree.Private_Part.Object_Paths.Table (Index2 - 1) :=
 344                  In_Tree.Private_Part.Object_Paths.Table (Index2);
 345             end loop;
 346
 347             In_Tree.Private_Part.Object_Paths.Table
 348               (Object_Path_Table.Last (In_Tree.Private_Part.Object_Paths)) :=
 349                  Object_Dir;
 350             return;
 351          end if;
 352       end loop;
 353
 354       --  The directory is not already in the table, add it
 355
 356       Object_Path_Table.Increment_Last (In_Tree.Private_Part.Object_Paths);
 357       In_Tree.Private_Part.Object_Paths.Table
 358         (Object_Path_Table.Last (In_Tree.Private_Part.Object_Paths)) :=
 359            Object_Dir;
 360    end Add_To_Object_Path;
 361
 362    -----------------
 363    -- Add_To_Path --
 364    -----------------
 365
 366    procedure Add_To_Path
 367      (Source_Dirs : String_List_Id;
 368       In_Tree     : Project_Tree_Ref)
 369    is
 370       Current    : String_List_Id := Source_Dirs;
 371       Source_Dir : String_Element;
 372    begin
 373       while Current /= Nil_String loop
 374          Source_Dir := In_Tree.String_Elements.Table (Current);
 375          Add_To_Path (Get_Name_String (Source_Dir.Display_Value));
 376          Current := Source_Dir.Next;
 377       end loop;
 378    end Add_To_Path;
 379
 380    procedure Add_To_Path (Dir : String) is
 381       Len        : Natural;
 382       New_Buffer : String_Access;
 383       Min_Len    : Natural;
 384
 385       function Is_Present (Path : String; Dir : String) return Boolean;
 386       --  Return True if Dir is part of Path
 387
 388       ----------------
 389       -- Is_Present --
 390       ----------------
 391
 392       function Is_Present (Path : String; Dir : String) return Boolean is
 393          Last : constant Integer := Path'Last - Dir'Length + 1;
 394
 395       begin
 396          for J in Path'First .. Last loop
 397
 398             --  Note: the order of the conditions below is important, since
 399             --  it ensures a minimal number of string comparisons.
 400
 401             if (J = Path'First
 402                 or else Path (J - 1) = Path_Separator)
 403               and then
 404                 (J + Dir'Length > Path'Last
 405                  or else Path (J + Dir'Length) = Path_Separator)
 406               and then Dir = Path (J .. J + Dir'Length - 1)
 407             then
 408                return True;
 409             end if;
 410          end loop;
 411
 412          return False;
 413       end Is_Present;
 414
 415    --  Start of processing for Add_To_Path
 416
 417    begin
 418       if Is_Present (Ada_Path_Buffer (1 .. Ada_Path_Length), Dir) then
 419
 420          --  Dir is already in the path, nothing to do
 421
 422          return;
 423       end if;
 424
 425       Min_Len := Ada_Path_Length + Dir'Length;
 426
 427       if Ada_Path_Length > 0 then
 428
 429          --  Add 1 for the Path_Separator character
 430
 431          Min_Len := Min_Len + 1;
 432       end if;
 433
 434       --  If Ada_Path_Buffer is too small, increase it
 435
 436       Len := Ada_Path_Buffer'Last;
 437
 438       if Len < Min_Len then
 439          loop
 440             Len := Len * 2;
 441             exit when Len >= Min_Len;
 442          end loop;
 443
 444          New_Buffer := new String (1 .. Len);
 445          New_Buffer (1 .. Ada_Path_Length) :=
 446            Ada_Path_Buffer (1 .. Ada_Path_Length);
 447          Free (Ada_Path_Buffer);
 448          Ada_Path_Buffer := New_Buffer;
 449       end if;
 450
 451       if Ada_Path_Length > 0 then
 452          Ada_Path_Length := Ada_Path_Length + 1;
 453          Ada_Path_Buffer (Ada_Path_Length) := Path_Separator;
 454       end if;
 455
 456       Ada_Path_Buffer
 457         (Ada_Path_Length + 1 .. Ada_Path_Length + Dir'Length) := Dir;
 458       Ada_Path_Length := Ada_Path_Length + Dir'Length;
 459    end Add_To_Path;
 460
 461    ------------------------
 462    -- Add_To_Source_Path --
 463    ------------------------
 464
 465    procedure Add_To_Source_Path
 466      (Source_Dirs : String_List_Id; In_Tree : Project_Tree_Ref)
 467    is
 468       Current    : String_List_Id := Source_Dirs;
 469       Source_Dir : String_Element;
 470       Add_It     : Boolean;
 471
 472    begin
 473       --  Add each source directory
 474
 475       while Current /= Nil_String loop
 476          Source_Dir := In_Tree.String_Elements.Table (Current);
 477          Add_It := True;
 478
 479          --  Check if the source directory is already in the table
 480
 481          for Index in Source_Path_Table.First ..
 482                       Source_Path_Table.Last
 483                                           (In_Tree.Private_Part.Source_Paths)
 484          loop
 485             --  If it is already, no need to add it
 486
 487             if In_Tree.Private_Part.Source_Paths.Table (Index) =
 488                         Source_Dir.Value
 489             then
 490                Add_It := False;
 491                exit;
 492             end if;
 493          end loop;
 494
 495          if Add_It then
 496             Source_Path_Table.Increment_Last
 497               (In_Tree.Private_Part.Source_Paths);
 498             In_Tree.Private_Part.Source_Paths.Table
 499               (Source_Path_Table.Last (In_Tree.Private_Part.Source_Paths)) :=
 500               Source_Dir.Value;
 501          end if;
 502
 503          --  Next source directory
 504
 505          Current := Source_Dir.Next;
 506       end loop;
 507    end Add_To_Source_Path;
 508
 509    -----------------------
 510    -- Body_Path_Name_Of --
 511    -----------------------
 512
 513    function Body_Path_Name_Of
 514      (Unit    : Unit_Index;
 515       In_Tree : Project_Tree_Ref) return String
 516    is
 517       Data : Unit_Data := In_Tree.Units.Table (Unit);
 518
 519    begin
 520       --  If we don't know the path name of the body of this unit,
 521       --  we compute it, and we store it.
 522
 523       if Data.File_Names (Body_Part).Path = No_Path then
 524          declare
 525             Current_Source : String_List_Id :=
 526               In_Tree.Projects.Table
 527                 (Data.File_Names (Body_Part).Project).Ada_Sources;
 528             Path : GNAT.OS_Lib.String_Access;
 529
 530          begin
 531             --  By default, put the file name
 532
 533             Data.File_Names (Body_Part).Path :=
 534               Path_Name_Type (Data.File_Names (Body_Part).Name);
 535
 536             --  For each source directory
 537
 538             while Current_Source /= Nil_String loop
 539                Path :=
 540                  Locate_Regular_File
 541                    (Namet.Get_Name_String
 542                       (Data.File_Names (Body_Part).Name),
 543                     Namet.Get_Name_String
 544                       (In_Tree.String_Elements.Table
 545                          (Current_Source).Value));
 546
 547                --  If the file is in this directory, then we store the path,
 548                --  and we are done.
 549
 550                if Path /= null then
 551                   Name_Len := Path'Length;
 552                   Name_Buffer (1 .. Name_Len) := Path.all;
 553                   Data.File_Names (Body_Part).Path := Name_Enter;
 554                   exit;
 555
 556                else
 557                   Current_Source :=
 558                     In_Tree.String_Elements.Table
 559                       (Current_Source).Next;
 560                end if;
 561             end loop;
 562
 563             In_Tree.Units.Table (Unit) := Data;
 564          end;
 565       end if;
 566
 567       --  Returned the stored value
 568
 569       return Namet.Get_Name_String (Data.File_Names (Body_Part).Path);
 570    end Body_Path_Name_Of;
 571
 572    ------------------------
 573    -- Contains_ALI_Files --
 574    ------------------------
 575
 576    function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean is
 577       Dir_Name : constant String := Get_Name_String (Dir);
 578       Direct : Dir_Type;
 579       Name   : String (1 .. 1_000);
 580       Last   : Natural;
 581       Result : Boolean := False;
 582
 583    begin
 584       Open (Direct, Dir_Name);
 585
 586       --  For each file in the directory, check if it is an ALI file
 587
 588       loop
 589          Read (Direct, Name, Last);
 590          exit when Last = 0;
 591          Canonical_Case_File_Name (Name (1 .. Last));
 592          Result := Last >= 5 and then Name (Last - 3 .. Last) = ".ali";
 593          exit when Result;
 594       end loop;
 595
 596       Close (Direct);
 597       return Result;
 598
 599    exception
 600       --  If there is any problem, close the directory if open and return
 601       --  True; the library directory will be added to the path.
 602
 603       when others =>
 604          if Is_Open (Direct) then
 605             Close (Direct);
 606          end if;
 607
 608          return True;
 609    end Contains_ALI_Files;
 610
 611    --------------------------------
 612    -- Create_Config_Pragmas_File --
 613    --------------------------------
 614
 615    procedure Create_Config_Pragmas_File
 616      (For_Project          : Project_Id;
 617       Main_Project         : Project_Id;
 618       In_Tree              : Project_Tree_Ref;
 619       Include_Config_Files : Boolean := True)
 620    is
 621       pragma Unreferenced (Main_Project);
 622       pragma Unreferenced (Include_Config_Files);
 623
 624       File_Name : Path_Name_Type  := No_Path;
 625       File      : File_Descriptor := Invalid_FD;
 626
 627       Current_Unit : Unit_Index := Unit_Table.First;
 628
 629       First_Project : Project_List := Empty_Project_List;
 630
 631       Current_Project : Project_List;
 632       Current_Naming  : Naming_Id;
 633
 634       Status : Boolean;
 635       --  For call to Close
 636
 637       procedure Check (Project : Project_Id);
 638       --  Recursive procedure that put in the config pragmas file any non
 639       --  standard naming schemes, if it is not already in the file, then call
 640       --  itself for any imported project.
 641
 642       procedure Check_Temp_File;
 643       --  Check that a temporary file has been opened.
 644       --  If not, create one, and put its name in the project data,
 645       --  with the indication that it is a temporary file.
 646
 647       procedure Put
 648         (Unit_Name : Name_Id;
 649          File_Name : File_Name_Type;
 650          Unit_Kind : Spec_Or_Body;
 651          Index     : Int);
 652       --  Put an SFN pragma in the temporary file
 653
 654       procedure Put (File : File_Descriptor; S : String);
 655       procedure Put_Line (File : File_Descriptor; S : String);
 656       --  Output procedures, analogous to normal Text_IO procs of same name
 657
 658       -----------
 659       -- Check --
 660       -----------
 661
 662       procedure Check (Project : Project_Id) is
 663          Data : constant Project_Data :=
 664            In_Tree.Projects.Table (Project);
 665
 666       begin
 667          if Current_Verbosity = High then
 668             Write_Str ("Checking project file """);
 669             Write_Str (Namet.Get_Name_String (Data.Name));
 670             Write_Str (""".");
 671             Write_Eol;
 672          end if;
 673
 674          --  Is this project in the list of the visited project?
 675
 676          Current_Project := First_Project;
 677          while Current_Project /= Empty_Project_List
 678            and then In_Tree.Project_Lists.Table
 679                       (Current_Project).Project /= Project
 680          loop
 681             Current_Project :=
 682               In_Tree.Project_Lists.Table (Current_Project).Next;
 683          end loop;
 684
 685          --  If it is not, put it in the list, and visit it
 686
 687          if Current_Project = Empty_Project_List then
 688             Project_List_Table.Increment_Last
 689               (In_Tree.Project_Lists);
 690             In_Tree.Project_Lists.Table
 691               (Project_List_Table.Last (In_Tree.Project_Lists)) :=
 692                  (Project => Project, Next => First_Project);
 693                First_Project :=
 694                  Project_List_Table.Last (In_Tree.Project_Lists);
 695
 696             --  Is the naming scheme of this project one that we know?
 697
 698             Current_Naming := Default_Naming;
 699             while Current_Naming <=
 700                     Naming_Table.Last (In_Tree.Private_Part.Namings)
 701               and then not Same_Naming_Scheme
 702               (Left => In_Tree.Private_Part.Namings.Table (Current_Naming),
 703                Right => Data.Naming) loop
 704                Current_Naming := Current_Naming + 1;
 705             end loop;
 706
 707             --  If we don't know it, add it
 708
 709             if Current_Naming >
 710                  Naming_Table.Last (In_Tree.Private_Part.Namings)
 711             then
 712                Naming_Table.Increment_Last (In_Tree.Private_Part.Namings);
 713                In_Tree.Private_Part.Namings.Table
 714                  (Naming_Table.Last (In_Tree.Private_Part.Namings)) :=
 715                     Data.Naming;
 716
 717                --  We need a temporary file to be created
 718
 719                Check_Temp_File;
 720
 721                --  Put the SFN pragmas for the naming scheme
 722
 723                --  Spec
 724
 725                Put_Line
 726                  (File, "pragma Source_File_Name_Project");
 727                Put_Line
 728                  (File, "  (Spec_File_Name  => ""*" &
 729                   Spec_Suffix_Of (In_Tree, "ada", Data.Naming) &
 730                   """,");
 731                Put_Line
 732                  (File, "   Casing          => " &
 733                   Image (Data.Naming.Casing) & ",");
 734                Put_Line
 735                  (File, "   Dot_Replacement => """ &
 736                  Namet.Get_Name_String (Data.Naming.Dot_Replacement) &
 737                   """);");
 738
 739                --  and body
 740
 741                Put_Line
 742                  (File, "pragma Source_File_Name_Project");
 743                Put_Line
 744                  (File, "  (Body_File_Name  => ""*" &
 745                   Body_Suffix_Of (In_Tree, "ada", Data.Naming) &
 746                   """,");
 747                Put_Line
 748                  (File, "   Casing          => " &
 749                   Image (Data.Naming.Casing) & ",");
 750                Put_Line
 751                  (File, "   Dot_Replacement => """ &
 752                   Namet.Get_Name_String (Data.Naming.Dot_Replacement) &
 753                   """);");
 754
 755                --  and maybe separate
 756
 757                if Body_Suffix_Of (In_Tree, "ada", Data.Naming) /=
 758                   Get_Name_String (Data.Naming.Separate_Suffix)
 759                then
 760                   Put_Line
 761                     (File, "pragma Source_File_Name_Project");
 762                   Put_Line
 763                     (File, "  (Subunit_File_Name  => ""*" &
 764                      Namet.Get_Name_String (Data.Naming.Separate_Suffix) &
 765                      """,");
 766                   Put_Line
 767                     (File, "   Casing          => " &
 768                      Image (Data.Naming.Casing) &
 769                      ",");
 770                   Put_Line
 771                     (File, "   Dot_Replacement => """ &
 772                      Namet.Get_Name_String (Data.Naming.Dot_Replacement) &
 773                      """);");
 774                end if;
 775             end if;
 776
 777             if Data.Extends /= No_Project then
 778                Check (Data.Extends);
 779             end if;
 780
 781             declare
 782                Current : Project_List := Data.Imported_Projects;
 783
 784             begin
 785                while Current /= Empty_Project_List loop
 786                   Check
 787                     (In_Tree.Project_Lists.Table
 788                        (Current).Project);
 789                   Current := In_Tree.Project_Lists.Table
 790                                (Current).Next;
 791                end loop;
 792             end;
 793          end if;
 794       end Check;
 795
 796       ---------------------
 797       -- Check_Temp_File --
 798       ---------------------
 799
 800       procedure Check_Temp_File is
 801       begin
 802          if File = Invalid_FD then
 803             Tempdir.Create_Temp_File (File, Name => File_Name);
 804
 805             if File = Invalid_FD then
 806                Prj.Com.Fail
 807                  ("unable to create temporary configuration pragmas file");
 808
 809             else
 810                Record_Temp_File (File_Name);
 811
 812                if Opt.Verbose_Mode then
 813                   Write_Str ("Creating temp file """);
 814                   Write_Str (Get_Name_String (File_Name));
 815                   Write_Line ("""");
 816                end if;
 817             end if;
 818          end if;
 819       end Check_Temp_File;
 820
 821       ---------
 822       -- Put --
 823       ---------
 824
 825       procedure Put
 826         (Unit_Name : Name_Id;
 827          File_Name : File_Name_Type;
 828          Unit_Kind : Spec_Or_Body;
 829          Index     : Int)
 830       is
 831       begin
 832          --  A temporary file needs to be open
 833
 834          Check_Temp_File;
 835
 836          --  Put the pragma SFN for the unit kind (spec or body)
 837
 838          Put (File, "pragma Source_File_Name_Project (");
 839          Put (File, Namet.Get_Name_String (Unit_Name));
 840
 841          if Unit_Kind = Specification then
 842             Put (File, ", Spec_File_Name => """);
 843          else
 844             Put (File, ", Body_File_Name => """);
 845          end if;
 846
 847          Put (File, Namet.Get_Name_String (File_Name));
 848          Put (File, """");
 849
 850          if Index /= 0 then
 851             Put (File, ", Index =>");
 852             Put (File, Index'Img);
 853          end if;
 854
 855          Put_Line (File, ");");
 856       end Put;
 857
 858       procedure Put (File : File_Descriptor; S : String) is
 859          Last : Natural;
 860
 861       begin
 862          Last := Write (File, S (S'First)'Address, S'Length);
 863
 864          if Last /= S'Length then
 865             Prj.Com.Fail ("Disk full");
 866          end if;
 867
 868          if Current_Verbosity = High then
 869             Write_Str (S);
 870          end if;
 871       end Put;
 872
 873       --------------
 874       -- Put_Line --
 875       --------------
 876
 877       procedure Put_Line (File : File_Descriptor; S : String) is
 878          S0   : String (1 .. S'Length + 1);
 879          Last : Natural;
 880
 881       begin
 882          --  Add an ASCII.LF to the string. As this config file is supposed to
 883          --  be used only by the compiler, we don't care about the characters
 884          --  for the end of line. In fact we could have put a space, but
 885          --  it is more convenient to be able to read gnat.adc during
 886          --  development, for which the ASCII.LF is fine.
 887
 888          S0 (1 .. S'Length) := S;
 889          S0 (S0'Last) := ASCII.LF;
 890          Last := Write (File, S0'Address, S0'Length);
 891
 892          if Last /= S'Length + 1 then
 893             Prj.Com.Fail ("Disk full");
 894          end if;
 895
 896          if Current_Verbosity = High then
 897             Write_Line (S);
 898          end if;
 899       end Put_Line;
 900
 901    --  Start of processing for Create_Config_Pragmas_File
 902
 903    begin
 904       if not
 905         In_Tree.Projects.Table (For_Project).Config_Checked
 906       then
 907
 908          --  Remove any memory of processed naming schemes, if any
 909
 910          Naming_Table.Set_Last (In_Tree.Private_Part.Namings, Default_Naming);
 911
 912          --  Check the naming schemes
 913
 914          Check (For_Project);
 915
 916          --  Visit all the units and process those that need an SFN pragma
 917
 918          while
 919            Current_Unit <= Unit_Table.Last (In_Tree.Units)
 920          loop
 921             declare
 922                Unit : constant Unit_Data :=
 923                  In_Tree.Units.Table (Current_Unit);
 924
 925             begin
 926                if Unit.File_Names (Specification).Needs_Pragma then
 927                   Put (Unit.Name,
 928                        Unit.File_Names (Specification).Name,
 929                        Specification,
 930                        Unit.File_Names (Specification).Index);
 931                end if;
 932
 933                if Unit.File_Names (Body_Part).Needs_Pragma then
 934                   Put (Unit.Name,
 935                        Unit.File_Names (Body_Part).Name,
 936                        Body_Part,
 937                        Unit.File_Names (Body_Part).Index);
 938                end if;
 939
 940                Current_Unit := Current_Unit + 1;
 941             end;
 942          end loop;
 943
 944          --  If there are no non standard naming scheme, issue the GNAT
 945          --  standard naming scheme. This will tell the compiler that
 946          --  a project file is used and will forbid any pragma SFN.
 947
 948          if File = Invalid_FD then
 949             Check_Temp_File;
 950
 951             Put_Line (File, "pragma Source_File_Name_Project");
 952             Put_Line (File, "   (Spec_File_Name  => ""*.ads"",");
 953             Put_Line (File, "    Dot_Replacement => ""-"",");
 954             Put_Line (File, "    Casing          => lowercase);");
 955
 956             Put_Line (File, "pragma Source_File_Name_Project");
 957             Put_Line (File, "   (Body_File_Name  => ""*.adb"",");
 958             Put_Line (File, "    Dot_Replacement => ""-"",");
 959             Put_Line (File, "    Casing          => lowercase);");
 960          end if;
 961
 962          --  Close the temporary file
 963
 964          GNAT.OS_Lib.Close (File, Status);
 965
 966          if not Status then
 967             Prj.Com.Fail ("disk full");
 968          end if;
 969
 970          if Opt.Verbose_Mode then
 971             Write_Str ("Closing configuration file """);
 972             Write_Str (Get_Name_String (File_Name));
 973             Write_Line ("""");
 974          end if;
 975
 976          In_Tree.Projects.Table (For_Project).Config_File_Name :=
 977            File_Name;
 978          In_Tree.Projects.Table (For_Project).Config_File_Temp :=
 979            True;
 980
 981          In_Tree.Projects.Table (For_Project).Config_Checked :=
 982            True;
 983       end if;
 984    end Create_Config_Pragmas_File;
 985
 986    --------------------
 987    -- Create_Mapping --
 988    --------------------
 989
 990    procedure Create_Mapping (In_Tree : Project_Tree_Ref) is
 991       The_Unit_Data : Unit_Data;
 992       Data          : File_Name_Data;
 993
 994    begin
 995       Fmap.Reset_Tables;
 996
 997       for Unit in 1 .. Unit_Table.Last (In_Tree.Units) loop
 998          The_Unit_Data := In_Tree.Units.Table (Unit);
 999
1000          --  Process only if the unit has a valid name
1001
1002          if The_Unit_Data.Name /= No_Name then
1003             Data := The_Unit_Data.File_Names (Specification);
1004
1005             --  If there is a spec, put it in the mapping
1006
1007             if Data.Name /= No_File then
1008                if Data.Path = Slash then
1009                   Fmap.Add_Forbidden_File_Name (Data.Name);
1010                else
1011                   Fmap.Add_To_File_Map
1012                     (Unit_Name => Unit_Name_Type (The_Unit_Data.Name),
1013                      File_Name => Data.Name,
1014                      Path_Name => File_Name_Type (Data.Path));
1015                end if;
1016             end if;
1017
1018             Data := The_Unit_Data.File_Names (Body_Part);
1019
1020             --  If there is a body (or subunit) put it in the mapping
1021
1022             if Data.Name /= No_File then
1023                if Data.Path = Slash then
1024                   Fmap.Add_Forbidden_File_Name (Data.Name);
1025                else
1026                   Fmap.Add_To_File_Map
1027                     (Unit_Name => Unit_Name_Type (The_Unit_Data.Name),
1028                      File_Name => Data.Name,
1029                      Path_Name => File_Name_Type (Data.Path));
1030                end if;
1031             end if;
1032          end if;
1033       end loop;
1034    end Create_Mapping;
1035
1036    -------------------------
1037    -- Create_Mapping_File --
1038    -------------------------
1039
1040    procedure Create_Mapping_File
1041      (Project : Project_Id;
1042       In_Tree : Project_Tree_Ref;
1043       Name    : out Path_Name_Type)
1044    is
1045       File          : File_Descriptor := Invalid_FD;
1046       The_Unit_Data : Unit_Data;
1047       Data          : File_Name_Data;
1048
1049       Status : Boolean;
1050       --  For call to Close
1051
1052       Present       : Project_Flags
1053         (No_Project .. Project_Table.Last (In_Tree.Projects)) :=
1054         (others => False);
1055       --  For each project in the closure of Project, the corresponding flag
1056       --  will be set to True;
1057
1058       procedure Put_Name_Buffer;
1059       --  Put the line contained in the Name_Buffer in the mapping file
1060
1061       procedure Put_Data (Spec : Boolean);
1062       --  Put the mapping of the spec or body contained in Data in the file
1063       --  (3 lines).
1064
1065       procedure Recursive_Flag (Prj : Project_Id);
1066       --  Set the flags corresponding to Prj, the projects it imports
1067       --  (directly or indirectly) or extends to True. Call itself recursively.
1068
1069       ---------
1070       -- Put --
1071       ---------
1072
1073       procedure Put_Name_Buffer is
1074          Last : Natural;
1075
1076       begin
1077          Name_Len := Name_Len + 1;
1078          Name_Buffer (Name_Len) := ASCII.LF;
1079          Last := Write (File, Name_Buffer (1)'Address, Name_Len);
1080
1081          if Last /= Name_Len then
1082             Prj.Com.Fail ("Disk full");
1083          end if;
1084       end Put_Name_Buffer;
1085
1086       --------------
1087       -- Put_Data --
1088       --------------
1089
1090       procedure Put_Data (Spec : Boolean) is
1091       begin
1092          --  Line with the unit name
1093
1094          Get_Name_String (The_Unit_Data.Name);
1095          Name_Len := Name_Len + 1;
1096          Name_Buffer (Name_Len) := '%';
1097          Name_Len := Name_Len + 1;
1098
1099          if Spec then
1100             Name_Buffer (Name_Len) := 's';
1101          else
1102             Name_Buffer (Name_Len) := 'b';
1103          end if;
1104
1105          Put_Name_Buffer;
1106
1107          --  Line with the file name
1108
1109          Get_Name_String (Data.Name);
1110          Put_Name_Buffer;
1111
1112          --  Line with the path name
1113
1114          Get_Name_String (Data.Path);
1115          Put_Name_Buffer;
1116
1117       end Put_Data;
1118
1119       --------------------
1120       -- Recursive_Flag --
1121       --------------------
1122
1123       procedure Recursive_Flag (Prj : Project_Id) is
1124          Imported : Project_List;
1125          Proj     : Project_Id;
1126
1127       begin
1128          --  Nothing to do for non existent project or project that has
1129          --  already been flagged.
1130
1131          if Prj = No_Project or else Present (Prj) then
1132             return;
1133          end if;
1134
1135          --  Flag the current project
1136
1137          Present (Prj) := True;
1138          Imported :=
1139            In_Tree.Projects.Table (Prj).Imported_Projects;
1140
1141          --  Call itself for each project directly imported
1142
1143          while Imported /= Empty_Project_List loop
1144             Proj :=
1145               In_Tree.Project_Lists.Table (Imported).Project;
1146             Imported :=
1147               In_Tree.Project_Lists.Table (Imported).Next;
1148             Recursive_Flag (Proj);
1149          end loop;
1150
1151          --  Call itself for an eventual project being extended
1152
1153          Recursive_Flag (In_Tree.Projects.Table (Prj).Extends);
1154       end Recursive_Flag;
1155
1156    --  Start of processing for Create_Mapping_File
1157
1158    begin
1159       --  Flag the necessary projects
1160
1161       Recursive_Flag (Project);
1162
1163       --  Create the temporary file
1164
1165       Tempdir.Create_Temp_File (File, Name => Name);
1166
1167       if File = Invalid_FD then
1168          Prj.Com.Fail ("unable to create temporary mapping file");
1169
1170       else
1171          Record_Temp_File (Name);
1172
1173          if Opt.Verbose_Mode then
1174             Write_Str ("Creating temp mapping file """);
1175             Write_Str (Get_Name_String (Name));
1176             Write_Line ("""");
1177          end if;
1178       end if;
1179
1180       if Fill_Mapping_File then
1181
1182          --  For all units in table Units
1183
1184          for Unit in 1 .. Unit_Table.Last (In_Tree.Units) loop
1185             The_Unit_Data := In_Tree.Units.Table (Unit);
1186
1187             --  If the unit has a valid name
1188
1189             if The_Unit_Data.Name /= No_Name then
1190                Data := The_Unit_Data.File_Names (Specification);
1191
1192                --  If there is a spec, put it mapping in the file if it is
1193                --  from a project in the closure of Project.
1194
1195                if Data.Name /= No_File and then Present (Data.Project) then
1196                   Put_Data (Spec => True);
1197                end if;
1198
1199                Data := The_Unit_Data.File_Names (Body_Part);
1200
1201                --  If there is a body (or subunit) put its mapping in the file
1202                --  if it is from a project in the closure of Project.
1203
1204                if Data.Name /= No_File and then Present (Data.Project) then
1205                   Put_Data (Spec => False);
1206                end if;
1207
1208             end if;
1209          end loop;
1210       end if;
1211
1212       GNAT.OS_Lib.Close (File, Status);
1213
1214       if not Status then
1215          Prj.Com.Fail ("disk full");
1216       end if;
1217    end Create_Mapping_File;
1218
1219    procedure Create_Mapping_File
1220      (Project  : Project_Id;
1221       Language : Name_Id;
1222       In_Tree  : Project_Tree_Ref;
1223       Name     : out Path_Name_Type)
1224    is
1225       File : File_Descriptor := Invalid_FD;
1226
1227       Status : Boolean;
1228       --  For call to Close
1229
1230       Present : Project_Flags
1231                  (No_Project .. Project_Table.Last (In_Tree.Projects)) :=
1232                    (others => False);
1233       --  For each project in the closure of Project, the corresponding flag
1234       --  will be set to True.
1235
1236       Source   : Source_Id;
1237       Src_Data : Source_Data;
1238       Suffix   : File_Name_Type;
1239
1240       procedure Put_Name_Buffer;
1241       --  Put the line contained in the Name_Buffer in the mapping file
1242
1243       procedure Recursive_Flag (Prj : Project_Id);
1244       --  Set the flags corresponding to Prj, the projects it imports
1245       --  (directly or indirectly) or extends to True. Call itself recursively.
1246
1247       ---------
1248       -- Put --
1249       ---------
1250
1251       procedure Put_Name_Buffer is
1252          Last : Natural;
1253
1254       begin
1255          Name_Len := Name_Len + 1;
1256          Name_Buffer (Name_Len) := ASCII.LF;
1257          Last := Write (File, Name_Buffer (1)'Address, Name_Len);
1258
1259          if Last /= Name_Len then
1260             Prj.Com.Fail ("Disk full");
1261          end if;
1262       end Put_Name_Buffer;
1263
1264       --------------------
1265       -- Recursive_Flag --
1266       --------------------
1267
1268       procedure Recursive_Flag (Prj : Project_Id) is
1269          Imported : Project_List;
1270          Proj     : Project_Id;
1271
1272       begin
1273          --  Nothing to do for non existent project or project that has already
1274          --  been flagged.
1275
1276          if Prj = No_Project or else Present (Prj) then
1277             return;
1278          end if;
1279
1280          --  Flag the current project
1281
1282          Present (Prj) := True;
1283          Imported :=
1284            In_Tree.Projects.Table (Prj).Imported_Projects;
1285
1286          --  Call itself for each project directly imported
1287
1288          while Imported /= Empty_Project_List loop
1289             Proj :=
1290               In_Tree.Project_Lists.Table (Imported).Project;
1291             Imported :=
1292               In_Tree.Project_Lists.Table (Imported).Next;
1293             Recursive_Flag (Proj);
1294          end loop;
1295
1296          --  Call itself for an eventual project being extended
1297
1298          Recursive_Flag (In_Tree.Projects.Table (Prj).Extends);
1299       end Recursive_Flag;
1300
1301    --  Start of processing for Create_Mapping_File
1302
1303    begin
1304       --  Flag the necessary projects
1305
1306       Recursive_Flag (Project);
1307
1308       --  Create the temporary file
1309
1310       Tempdir.Create_Temp_File (File, Name => Name);
1311
1312       if File = Invalid_FD then
1313          Prj.Com.Fail ("unable to create temporary mapping file");
1314
1315       else
1316          Record_Temp_File (Name);
1317
1318          if Opt.Verbose_Mode then
1319             Write_Str ("Creating temp mapping file """);
1320             Write_Str (Get_Name_String (Name));
1321             Write_Line ("""");
1322          end if;
1323       end if;
1324
1325       --  For all source of the Language of all projects in the closure
1326
1327       for Proj in Present'Range loop
1328          if Present (Proj) then
1329             Source := In_Tree.Projects.Table (Proj).First_Source;
1330
1331             while Source /= No_Source loop
1332                Src_Data := In_Tree.Sources.Table (Source);
1333
1334                if Src_Data.Language_Name = Language and then
1335                  (not Src_Data.Locally_Removed) and then
1336                  Src_Data.Replaced_By = No_Source
1337                then
1338                   if Src_Data.Unit /= No_Name then
1339                      Get_Name_String (Src_Data.Unit);
1340
1341                      if Src_Data.Kind = Spec then
1342                         Suffix := In_Tree.Languages_Data.Table
1343                           (Src_Data.Language).Config.Mapping_Spec_Suffix;
1344
1345                      else
1346                         Suffix := In_Tree.Languages_Data.Table
1347                           (Src_Data.Language).Config.Mapping_Body_Suffix;
1348                      end if;
1349
1350                      if Suffix /= No_File then
1351                         Add_Str_To_Name_Buffer (Get_Name_String (Suffix));
1352                      end if;
1353
1354                      Put_Name_Buffer;
1355                   end if;
1356
1357                   Get_Name_String (Src_Data.File);
1358                   Put_Name_Buffer;
1359
1360                   Get_Name_String (Src_Data.Path);
1361                   Put_Name_Buffer;
1362                end if;
1363
1364                Source := Src_Data.Next_In_Project;
1365             end loop;
1366          end if;
1367       end loop;
1368
1369       GNAT.OS_Lib.Close (File, Status);
1370
1371       if not Status then
1372          Prj.Com.Fail ("disk full");
1373       end if;
1374    end Create_Mapping_File;
1375
1376    --------------------------
1377    -- Create_New_Path_File --
1378    --------------------------
1379
1380    procedure Create_New_Path_File
1381      (In_Tree   : Project_Tree_Ref;
1382       Path_FD   : out File_Descriptor;
1383       Path_Name : out Path_Name_Type)
1384    is
1385    begin
1386       Tempdir.Create_Temp_File (Path_FD, Path_Name);
1387
1388       if Path_Name /= No_Path then
1389          Record_Temp_File (Path_Name);
1390
1391          --  Record the name, so that the temp path file will be deleted at the
1392          --  end of the program.
1393
1394          Path_File_Table.Increment_Last (In_Tree.Private_Part.Path_Files);
1395          In_Tree.Private_Part.Path_Files.Table
1396            (Path_File_Table.Last (In_Tree.Private_Part.Path_Files)) :=
1397               Path_Name;
1398       end if;
1399    end Create_New_Path_File;
1400
1401    ---------------------------
1402    -- Delete_All_Path_Files --
1403    ---------------------------
1404
1405    procedure Delete_All_Path_Files (In_Tree : Project_Tree_Ref) is
1406       Disregard : Boolean := True;
1407
1408    begin
1409       for Index in Path_File_Table.First ..
1410                    Path_File_Table.Last (In_Tree.Private_Part.Path_Files)
1411       loop
1412          if In_Tree.Private_Part.Path_Files.Table (Index) /= No_Path then
1413             Delete_File
1414               (Get_Name_String
1415                  (In_Tree.Private_Part.Path_Files.Table (Index)),
1416                Disregard);
1417          end if;
1418       end loop;
1419
1420       --  If any of the environment variables ADA_PRJ_INCLUDE_FILE or
1421       --  ADA_PRJ_OBJECTS_FILE has been set, then reset their value to
1422       --  the empty string. On VMS, this has the effect of deassigning
1423       --  the logical names.
1424
1425       if Ada_Prj_Include_File_Set then
1426          Setenv (Project_Include_Path_File, "");
1427          Ada_Prj_Include_File_Set := False;
1428       end if;
1429
1430       if Ada_Prj_Objects_File_Set then
1431          Setenv (Project_Objects_Path_File, "");
1432          Ada_Prj_Objects_File_Set := False;
1433       end if;
1434    end Delete_All_Path_Files;
1435
1436    ------------------------------------
1437    -- File_Name_Of_Library_Unit_Body --
1438    ------------------------------------
1439
1440    function File_Name_Of_Library_Unit_Body
1441      (Name              : String;
1442       Project           : Project_Id;
1443       In_Tree           : Project_Tree_Ref;
1444       Main_Project_Only : Boolean := True;
1445       Full_Path         : Boolean := False) return String
1446    is
1447       The_Project   : Project_Id := Project;
1448       Data          : Project_Data :=
1449                         In_Tree.Projects.Table (Project);
1450       Original_Name : String := Name;
1451
1452       Extended_Spec_Name : String :=
1453                              Name &
1454                              Spec_Suffix_Of (In_Tree, "ada", Data.Naming);
1455       Extended_Body_Name : String :=
1456                              Name &
1457                              Body_Suffix_Of (In_Tree, "ada", Data.Naming);
1458
1459       Unit : Unit_Data;
1460
1461       The_Original_Name : Name_Id;
1462       The_Spec_Name     : Name_Id;
1463       The_Body_Name     : Name_Id;
1464
1465    begin
1466       Canonical_Case_File_Name (Original_Name);
1467       Name_Len := Original_Name'Length;
1468       Name_Buffer (1 .. Name_Len) := Original_Name;
1469       The_Original_Name := Name_Find;
1470
1471       Canonical_Case_File_Name (Extended_Spec_Name);
1472       Name_Len := Extended_Spec_Name'Length;
1473       Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
1474       The_Spec_Name := Name_Find;
1475
1476       Canonical_Case_File_Name (Extended_Body_Name);
1477       Name_Len := Extended_Body_Name'Length;
1478       Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
1479       The_Body_Name := Name_Find;
1480
1481       if Current_Verbosity = High then
1482          Write_Str  ("Looking for file name of """);
1483          Write_Str  (Name);
1484          Write_Char ('"');
1485          Write_Eol;
1486          Write_Str  ("   Extended Spec Name = """);
1487          Write_Str  (Extended_Spec_Name);
1488          Write_Char ('"');
1489          Write_Eol;
1490          Write_Str  ("   Extended Body Name = """);
1491          Write_Str  (Extended_Body_Name);
1492          Write_Char ('"');
1493          Write_Eol;
1494       end if;
1495
1496       --  For extending project, search in the extended project if the source
1497       --  is not found. For non extending projects, this loop will be run only
1498       --  once.
1499
1500       loop
1501          --  Loop through units
1502          --  Should have comment explaining reverse ???
1503
1504          for Current in reverse Unit_Table.First ..
1505                                 Unit_Table.Last (In_Tree.Units)
1506          loop
1507             Unit := In_Tree.Units.Table (Current);
1508
1509             --  Check for body
1510
1511             if not Main_Project_Only
1512               or else Unit.File_Names (Body_Part).Project = The_Project
1513             then
1514                declare
1515                   Current_Name : constant File_Name_Type :=
1516                                    Unit.File_Names (Body_Part).Name;
1517
1518                begin
1519                   --  Case of a body present
1520
1521                   if Current_Name /= No_File then
1522                      if Current_Verbosity = High then
1523                         Write_Str  ("   Comparing with """);
1524                         Write_Str  (Get_Name_String (Current_Name));
1525                         Write_Char ('"');
1526                         Write_Eol;
1527                      end if;
1528
1529                      --  If it has the name of the original name, return the
1530                      --  original name.
1531
1532                      if Unit.Name = The_Original_Name
1533                        or else
1534                          Current_Name = File_Name_Type (The_Original_Name)
1535                      then
1536                         if Current_Verbosity = High then
1537                            Write_Line ("   OK");
1538                         end if;
1539
1540                         if Full_Path then
1541                            return Get_Name_String
1542                              (Unit.File_Names (Body_Part).Path);
1543
1544                         else
1545                            return Get_Name_String (Current_Name);
1546                         end if;
1547
1548                         --  If it has the name of the extended body name,
1549                         --  return the extended body name
1550
1551                      elsif Current_Name = File_Name_Type (The_Body_Name) then
1552                         if Current_Verbosity = High then
1553                            Write_Line ("   OK");
1554                         end if;
1555
1556                         if Full_Path then
1557                            return Get_Name_String
1558                              (Unit.File_Names (Body_Part).Path);
1559
1560                         else
1561                            return Extended_Body_Name;
1562                         end if;
1563
1564                      else
1565                         if Current_Verbosity = High then
1566                            Write_Line ("   not good");
1567                         end if;
1568                      end if;
1569                   end if;
1570                end;
1571             end if;
1572
1573             --  Check for spec
1574
1575             if not Main_Project_Only
1576               or else Unit.File_Names (Specification).Project = The_Project
1577             then
1578                declare
1579                   Current_Name : constant File_Name_Type :=
1580                                    Unit.File_Names (Specification).Name;
1581
1582                begin
1583                   --  Case of spec present
1584
1585                   if Current_Name /= No_File then
1586                      if Current_Verbosity = High then
1587                         Write_Str  ("   Comparing with """);
1588                         Write_Str  (Get_Name_String (Current_Name));
1589                         Write_Char ('"');
1590                         Write_Eol;
1591                      end if;
1592
1593                      --  If name same as original name, return original name
1594
1595                      if Unit.Name = The_Original_Name
1596                        or else
1597                          Current_Name = File_Name_Type (The_Original_Name)
1598                      then
1599                         if Current_Verbosity = High then
1600                            Write_Line ("   OK");
1601                         end if;
1602
1603                         if Full_Path then
1604                            return Get_Name_String
1605                              (Unit.File_Names (Specification).Path);
1606                         else
1607                            return Get_Name_String (Current_Name);
1608                         end if;
1609
1610                         --  If it has the same name as the extended spec name,
1611                         --  return the extended spec name.
1612
1613                      elsif Current_Name = File_Name_Type (The_Spec_Name) then
1614                         if Current_Verbosity = High then
1615                            Write_Line ("   OK");
1616                         end if;
1617
1618                         if Full_Path then
1619                            return Get_Name_String
1620                              (Unit.File_Names (Specification).Path);
1621                         else
1622                            return Extended_Spec_Name;
1623                         end if;
1624
1625                      else
1626                         if Current_Verbosity = High then
1627                            Write_Line ("   not good");
1628                         end if;
1629                      end if;
1630                   end if;
1631                end;
1632             end if;
1633          end loop;
1634
1635          --  If we are not in an extending project, give up
1636
1637          exit when (not Main_Project_Only) or else Data.Extends = No_Project;
1638
1639          --  Otherwise, look in the project we are extending
1640
1641          The_Project := Data.Extends;
1642          Data := In_Tree.Projects.Table (The_Project);
1643       end loop;
1644
1645       --  We don't know this file name, return an empty string
1646
1647       return "";
1648    end File_Name_Of_Library_Unit_Body;
1649
1650    -------------------------
1651    -- For_All_Object_Dirs --
1652    -------------------------
1653
1654    procedure For_All_Object_Dirs
1655      (Project : Project_Id;
1656       In_Tree : Project_Tree_Ref)
1657    is
1658       Seen : Project_List := Empty_Project_List;
1659
1660       procedure Add (Project : Project_Id);
1661       --  Process a project. Remember the processes visited to avoid processing
1662       --  a project twice. Recursively process an eventual extended project,
1663       --  and all imported projects.
1664
1665       ---------
1666       -- Add --
1667       ---------
1668
1669       procedure Add (Project : Project_Id) is
1670          Data : constant Project_Data :=
1671                   In_Tree.Projects.Table (Project);
1672          List : Project_List := Data.Imported_Projects;
1673
1674       begin
1675          --  If the list of visited project is empty, then
1676          --  for sure we never visited this project.
1677
1678          if Seen = Empty_Project_List then
1679             Project_List_Table.Increment_Last (In_Tree.Project_Lists);
1680             Seen := Project_List_Table.Last (In_Tree.Project_Lists);
1681             In_Tree.Project_Lists.Table (Seen) :=
1682               (Project => Project, Next => Empty_Project_List);
1683
1684          else
1685             --  Check if the project is in the list
1686
1687             declare
1688                Current : Project_List := Seen;
1689
1690             begin
1691                loop
1692                   --  If it is, then there is nothing else to do
1693
1694                   if In_Tree.Project_Lists.Table
1695                                            (Current).Project = Project
1696                   then
1697                      return;
1698                   end if;
1699
1700                   exit when
1701                     In_Tree.Project_Lists.Table (Current).Next =
1702                       Empty_Project_List;
1703                   Current :=
1704                     In_Tree.Project_Lists.Table (Current).Next;
1705                end loop;
1706
1707                --  This project has never been visited, add it
1708                --  to the list.
1709
1710                Project_List_Table.Increment_Last
1711                  (In_Tree.Project_Lists);
1712                In_Tree.Project_Lists.Table (Current).Next :=
1713                  Project_List_Table.Last (In_Tree.Project_Lists);
1714                In_Tree.Project_Lists.Table
1715                  (Project_List_Table.Last
1716                     (In_Tree.Project_Lists)) :=
1717                  (Project => Project, Next => Empty_Project_List);
1718             end;
1719          end if;
1720
1721          --  If there is an object directory, call Action with its name
1722
1723          if Data.Object_Directory /= No_Path then
1724             Get_Name_String (Data.Display_Object_Dir);
1725             Action (Name_Buffer (1 .. Name_Len));
1726          end if;
1727
1728          --  If we are extending a project, visit it
1729
1730          if Data.Extends /= No_Project then
1731             Add (Data.Extends);
1732          end if;
1733
1734          --  And visit all imported projects
1735
1736          while List /= Empty_Project_List loop
1737             Add (In_Tree.Project_Lists.Table (List).Project);
1738             List := In_Tree.Project_Lists.Table (List).Next;
1739          end loop;
1740       end Add;
1741
1742    --  Start of processing for For_All_Object_Dirs
1743
1744    begin
1745       --  Visit this project, and its imported projects, recursively
1746
1747       Add (Project);
1748    end For_All_Object_Dirs;
1749
1750    -------------------------
1751    -- For_All_Source_Dirs --
1752    -------------------------
1753
1754    procedure For_All_Source_Dirs
1755      (Project : Project_Id;
1756       In_Tree : Project_Tree_Ref)
1757    is
1758       Seen : Project_List := Empty_Project_List;
1759
1760       procedure Add (Project : Project_Id);
1761       --  Process a project. Remember the processes visited to avoid processing
1762       --  a project twice. Recursively process an eventual extended project,
1763       --  and all imported projects.
1764
1765       ---------
1766       -- Add --
1767       ---------
1768
1769       procedure Add (Project : Project_Id) is
1770          Data : constant Project_Data :=
1771                   In_Tree.Projects.Table (Project);
1772          List : Project_List := Data.Imported_Projects;
1773
1774       begin
1775          --  If the list of visited project is empty, then for sure we never
1776          --  visited this project.
1777
1778          if Seen = Empty_Project_List then
1779             Project_List_Table.Increment_Last
1780               (In_Tree.Project_Lists);
1781             Seen := Project_List_Table.Last
1782                                          (In_Tree.Project_Lists);
1783             In_Tree.Project_Lists.Table (Seen) :=
1784               (Project => Project, Next => Empty_Project_List);
1785
1786          else
1787             --  Check if the project is in the list
1788
1789             declare
1790                Current : Project_List := Seen;
1791
1792             begin
1793                loop
1794                   --  If it is, then there is nothing else to do
1795
1796                   if In_Tree.Project_Lists.Table
1797                                            (Current).Project = Project
1798                   then
1799                      return;
1800                   end if;
1801
1802                   exit when
1803                     In_Tree.Project_Lists.Table (Current).Next =
1804                       Empty_Project_List;
1805                   Current :=
1806                     In_Tree.Project_Lists.Table (Current).Next;
1807                end loop;
1808
1809                --  This project has never been visited, add it to the list
1810
1811                Project_List_Table.Increment_Last
1812                  (In_Tree.Project_Lists);
1813                In_Tree.Project_Lists.Table (Current).Next :=
1814                  Project_List_Table.Last (In_Tree.Project_Lists);
1815                In_Tree.Project_Lists.Table
1816                  (Project_List_Table.Last
1817                     (In_Tree.Project_Lists)) :=
1818                  (Project => Project, Next => Empty_Project_List);
1819             end;
1820          end if;
1821
1822          declare
1823             Current    : String_List_Id := Data.Source_Dirs;
1824             The_String : String_Element;
1825
1826          begin
1827             --  If there are Ada sources, call action with the name of every
1828             --  source directory.
1829
1830             if
1831               In_Tree.Projects.Table (Project).Ada_Sources /= Nil_String
1832             then
1833                while Current /= Nil_String loop
1834                   The_String :=
1835                     In_Tree.String_Elements.Table (Current);
1836                   Action (Get_Name_String (The_String.Display_Value));
1837                   Current := The_String.Next;
1838                end loop;
1839             end if;
1840          end;
1841
1842          --  If we are extending a project, visit it
1843
1844          if Data.Extends /= No_Project then
1845             Add (Data.Extends);
1846          end if;
1847
1848          --  And visit all imported projects
1849
1850          while List /= Empty_Project_List loop
1851             Add (In_Tree.Project_Lists.Table (List).Project);
1852             List := In_Tree.Project_Lists.Table (List).Next;
1853          end loop;
1854       end Add;
1855
1856    --  Start of processing for For_All_Source_Dirs
1857
1858    begin
1859       --  Visit this project, and its imported projects recursively
1860
1861       Add (Project);
1862    end For_All_Source_Dirs;
1863
1864    -------------------
1865    -- Get_Reference --
1866    -------------------
1867
1868    procedure Get_Reference
1869      (Source_File_Name : String;
1870       In_Tree          : Project_Tree_Ref;
1871       Project          : out Project_Id;
1872       Path             : out Path_Name_Type)
1873    is
1874    begin
1875       --  Body below could use some comments ???
1876
1877       if Current_Verbosity > Default then
1878          Write_Str ("Getting Reference_Of (""");
1879          Write_Str (Source_File_Name);
1880          Write_Str (""") ... ");
1881       end if;
1882
1883       declare
1884          Original_Name : String := Source_File_Name;
1885          Unit          : Unit_Data;
1886
1887       begin
1888          Canonical_Case_File_Name (Original_Name);
1889
1890          for Id in Unit_Table.First ..
1891                    Unit_Table.Last (In_Tree.Units)
1892          loop
1893             Unit := In_Tree.Units.Table (Id);
1894
1895             if (Unit.File_Names (Specification).Name /= No_File
1896                  and then
1897                    Namet.Get_Name_String
1898                      (Unit.File_Names (Specification).Name) = Original_Name)
1899               or else (Unit.File_Names (Specification).Path /= No_Path
1900                          and then
1901                            Namet.Get_Name_String
1902                            (Unit.File_Names (Specification).Path) =
1903                                                               Original_Name)
1904             then
1905                Project := Ultimate_Extension_Of
1906                            (Project => Unit.File_Names (Specification).Project,
1907                             In_Tree => In_Tree);
1908                Path := Unit.File_Names (Specification).Display_Path;
1909
1910                if Current_Verbosity > Default then
1911                   Write_Str ("Done: Specification.");
1912                   Write_Eol;
1913                end if;
1914
1915                return;
1916
1917             elsif (Unit.File_Names (Body_Part).Name /= No_File
1918                     and then
1919                       Namet.Get_Name_String
1920                         (Unit.File_Names (Body_Part).Name) = Original_Name)
1921               or else (Unit.File_Names (Body_Part).Path /= No_Path
1922                          and then Namet.Get_Name_String
1923                                     (Unit.File_Names (Body_Part).Path) =
1924                                                              Original_Name)
1925             then
1926                Project := Ultimate_Extension_Of
1927                             (Project => Unit.File_Names (Body_Part).Project,
1928                              In_Tree => In_Tree);
1929                Path := Unit.File_Names (Body_Part).Display_Path;
1930
1931                if Current_Verbosity > Default then
1932                   Write_Str ("Done: Body.");
1933                   Write_Eol;
1934                end if;
1935
1936                return;
1937             end if;
1938          end loop;
1939       end;
1940
1941       Project := No_Project;
1942       Path    := No_Path;
1943
1944       if Current_Verbosity > Default then
1945          Write_Str ("Cannot be found.");
1946          Write_Eol;
1947       end if;
1948    end Get_Reference;
1949
1950    ----------------
1951    -- Initialize --
1952    ----------------
1953
1954    procedure Initialize is
1955    begin
1956       Fill_Mapping_File := True;
1957    end Initialize;
1958
1959    ------------------------------------
1960    -- Path_Name_Of_Library_Unit_Body --
1961    ------------------------------------
1962
1963    --  Could use some comments in the body here ???
1964
1965    function Path_Name_Of_Library_Unit_Body
1966      (Name    : String;
1967       Project : Project_Id;
1968       In_Tree : Project_Tree_Ref) return String
1969    is
1970       Data          : constant Project_Data :=
1971                         In_Tree.Projects.Table (Project);
1972       Original_Name : String := Name;
1973
1974       Extended_Spec_Name : String :=
1975                              Name &
1976                              Spec_Suffix_Of (In_Tree, "ada", Data.Naming);
1977       Extended_Body_Name : String :=
1978                              Name &
1979                              Body_Suffix_Of (In_Tree, "ada", Data.Naming);
1980
1981       First   : Unit_Index := Unit_Table.First;
1982       Current : Unit_Index;
1983       Unit    : Unit_Data;
1984
1985    begin
1986       Canonical_Case_File_Name (Original_Name);
1987       Canonical_Case_File_Name (Extended_Spec_Name);
1988       Canonical_Case_File_Name (Extended_Body_Name);
1989
1990       if Current_Verbosity = High then
1991          Write_Str  ("Looking for path name of """);
1992          Write_Str  (Name);
1993          Write_Char ('"');
1994          Write_Eol;
1995          Write_Str  ("   Extended Spec Name = """);
1996          Write_Str  (Extended_Spec_Name);
1997          Write_Char ('"');
1998          Write_Eol;
1999          Write_Str  ("   Extended Body Name = """);
2000          Write_Str  (Extended_Body_Name);
2001          Write_Char ('"');
2002          Write_Eol;
2003       end if;
2004
2005       while First <= Unit_Table.Last (In_Tree.Units)
2006         and then In_Tree.Units.Table
2007                    (First).File_Names (Body_Part).Project /= Project
2008       loop
2009          First := First + 1;
2010       end loop;
2011
2012       Current := First;
2013       while Current <= Unit_Table.Last (In_Tree.Units) loop
2014          Unit := In_Tree.Units.Table (Current);
2015
2016          if Unit.File_Names (Body_Part).Project = Project
2017            and then Unit.File_Names (Body_Part).Name /= No_File
2018          then
2019             declare
2020                Current_Name : constant String :=
2021                  Namet.Get_Name_String (Unit.File_Names (Body_Part).Name);
2022             begin
2023                if Current_Verbosity = High then
2024                   Write_Str  ("   Comparing with """);
2025                   Write_Str  (Current_Name);
2026                   Write_Char ('"');
2027                   Write_Eol;
2028                end if;
2029
2030                if Current_Name = Original_Name then
2031                   if Current_Verbosity = High then
2032                      Write_Line ("   OK");
2033                   end if;
2034
2035                   return Body_Path_Name_Of (Current, In_Tree);
2036
2037                elsif Current_Name = Extended_Body_Name then
2038                   if Current_Verbosity = High then
2039                      Write_Line ("   OK");
2040                   end if;
2041
2042                   return Body_Path_Name_Of (Current, In_Tree);
2043
2044                else
2045                   if Current_Verbosity = High then
2046                      Write_Line ("   not good");
2047                   end if;
2048                end if;
2049             end;
2050
2051          elsif Unit.File_Names (Specification).Name /= No_File then
2052             declare
2053                Current_Name : constant String :=
2054                                 Namet.Get_Name_String
2055                                   (Unit.File_Names (Specification).Name);
2056
2057             begin
2058                if Current_Verbosity = High then
2059                   Write_Str  ("   Comparing with """);
2060                   Write_Str  (Current_Name);
2061                   Write_Char ('"');
2062                   Write_Eol;
2063                end if;
2064
2065                if Current_Name = Original_Name then
2066                   if Current_Verbosity = High then
2067                      Write_Line ("   OK");
2068                   end if;
2069
2070                   return Spec_Path_Name_Of (Current, In_Tree);
2071
2072                elsif Current_Name = Extended_Spec_Name then
2073                   if Current_Verbosity = High then
2074                      Write_Line ("   OK");
2075                   end if;
2076
2077                   return Spec_Path_Name_Of (Current, In_Tree);
2078
2079                else
2080                   if Current_Verbosity = High then
2081                      Write_Line ("   not good");
2082                   end if;
2083                end if;
2084             end;
2085          end if;
2086          Current := Current + 1;
2087       end loop;
2088
2089       return "";
2090    end Path_Name_Of_Library_Unit_Body;
2091
2092    -------------------
2093    -- Print_Sources --
2094    -------------------
2095
2096    --  Could use some comments in this body ???
2097
2098    procedure Print_Sources (In_Tree : Project_Tree_Ref) is
2099       Unit : Unit_Data;
2100
2101    begin
2102       Write_Line ("List of Sources:");
2103
2104       for Id in Unit_Table.First ..
2105                 Unit_Table.Last (In_Tree.Units)
2106       loop
2107          Unit := In_Tree.Units.Table (Id);
2108          Write_Str  ("   ");
2109          Write_Line (Namet.Get_Name_String (Unit.Name));
2110
2111          if Unit.File_Names (Specification).Name /= No_File then
2112             if Unit.File_Names (Specification).Project = No_Project then
2113                Write_Line ("   No project");
2114
2115             else
2116                Write_Str  ("   Project: ");
2117                Get_Name_String
2118                  (In_Tree.Projects.Table
2119                    (Unit.File_Names (Specification).Project).Path_Name);
2120                Write_Line (Name_Buffer (1 .. Name_Len));
2121             end if;
2122
2123             Write_Str  ("      spec: ");
2124             Write_Line
2125               (Namet.Get_Name_String
2126                (Unit.File_Names (Specification).Name));
2127          end if;
2128
2129          if Unit.File_Names (Body_Part).Name /= No_File then
2130             if Unit.File_Names (Body_Part).Project = No_Project then
2131                Write_Line ("   No project");
2132
2133             else
2134                Write_Str  ("   Project: ");
2135                Get_Name_String
2136                  (In_Tree.Projects.Table
2137                    (Unit.File_Names (Body_Part).Project).Path_Name);
2138                Write_Line (Name_Buffer (1 .. Name_Len));
2139             end if;
2140
2141             Write_Str  ("      body: ");
2142             Write_Line
2143               (Namet.Get_Name_String
2144                (Unit.File_Names (Body_Part).Name));
2145          end if;
2146       end loop;
2147
2148       Write_Line ("end of List of Sources.");
2149    end Print_Sources;
2150
2151    ----------------
2152    -- Project_Of --
2153    ----------------
2154
2155    function Project_Of
2156      (Name         : String;
2157       Main_Project : Project_Id;
2158       In_Tree      : Project_Tree_Ref) return Project_Id
2159    is
2160       Result : Project_Id := No_Project;
2161
2162       Original_Name : String := Name;
2163
2164       Data   : constant Project_Data :=
2165         In_Tree.Projects.Table (Main_Project);
2166
2167       Extended_Spec_Name : String :=
2168                              Name &
2169                              Spec_Suffix_Of (In_Tree, "ada", Data.Naming);
2170       Extended_Body_Name : String :=
2171                              Name &
2172                              Body_Suffix_Of (In_Tree, "ada", Data.Naming);
2173
2174       Unit : Unit_Data;
2175
2176       Current_Name      : File_Name_Type;
2177       The_Original_Name : File_Name_Type;
2178       The_Spec_Name     : File_Name_Type;
2179       The_Body_Name     : File_Name_Type;
2180
2181    begin
2182       Canonical_Case_File_Name (Original_Name);
2183       Name_Len := Original_Name'Length;
2184       Name_Buffer (1 .. Name_Len) := Original_Name;
2185       The_Original_Name := Name_Find;
2186
2187       Canonical_Case_File_Name (Extended_Spec_Name);
2188       Name_Len := Extended_Spec_Name'Length;
2189       Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
2190       The_Spec_Name := Name_Find;
2191
2192       Canonical_Case_File_Name (Extended_Body_Name);
2193       Name_Len := Extended_Body_Name'Length;
2194       Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
2195       The_Body_Name := Name_Find;
2196
2197       for Current in reverse Unit_Table.First ..
2198                              Unit_Table.Last (In_Tree.Units)
2199       loop
2200          Unit := In_Tree.Units.Table (Current);
2201
2202          --  Check for body
2203
2204          Current_Name := Unit.File_Names (Body_Part).Name;
2205
2206          --  Case of a body present
2207
2208          if Current_Name /= No_File then
2209
2210             --  If it has the name of the original name or the body name,
2211             --  we have found the project.
2212
2213             if Unit.Name = Name_Id (The_Original_Name)
2214               or else Current_Name = The_Original_Name
2215               or else Current_Name = The_Body_Name
2216             then
2217                Result := Unit.File_Names (Body_Part).Project;
2218                exit;
2219             end if;
2220          end if;
2221
2222          --  Check for spec
2223
2224          Current_Name := Unit.File_Names (Specification).Name;
2225
2226          if Current_Name /= No_File then
2227
2228             --  If name same as the original name, or the spec name, we have
2229             --  found the project.
2230
2231             if Unit.Name = Name_Id (The_Original_Name)
2232               or else Current_Name = The_Original_Name
2233               or else Current_Name = The_Spec_Name
2234             then
2235                Result := Unit.File_Names (Specification).Project;
2236                exit;
2237             end if;
2238          end if;
2239       end loop;
2240
2241       --  Get the ultimate extending project
2242
2243       if Result /= No_Project then
2244          while In_Tree.Projects.Table (Result).Extended_By /=
2245            No_Project
2246          loop
2247             Result := In_Tree.Projects.Table (Result).Extended_By;
2248          end loop;
2249       end if;
2250
2251       return Result;
2252    end Project_Of;
2253
2254    -------------------
2255    -- Set_Ada_Paths --
2256    -------------------
2257
2258    procedure Set_Ada_Paths
2259      (Project             : Project_Id;
2260       In_Tree             : Project_Tree_Ref;
2261       Including_Libraries : Boolean)
2262    is
2263       Source_FD : File_Descriptor := Invalid_FD;
2264       Object_FD : File_Descriptor := Invalid_FD;
2265
2266       Process_Source_Dirs : Boolean := False;
2267       Process_Object_Dirs : Boolean := False;
2268
2269       Status : Boolean;
2270       --  For calls to Close
2271
2272       Len : Natural;
2273
2274       procedure Add (Proj : Project_Id);
2275       --  Add all the source/object directories of a project to the path only
2276       --  if this project has not been visited. Calls an internal procedure
2277       --  recursively for projects being extended, and imported projects.
2278
2279       ---------
2280       -- Add --
2281       ---------
2282
2283       procedure Add (Proj : Project_Id) is
2284
2285          procedure Recursive_Add (Project : Project_Id);
2286          --  Recursive procedure to add the source/object paths of extended/
2287          --  imported projects.
2288
2289          -------------------
2290          -- Recursive_Add --
2291          -------------------
2292
2293          procedure Recursive_Add (Project : Project_Id) is
2294          begin
2295             --  If Seen is False, then the project has not yet been visited
2296
2297             if not In_Tree.Projects.Table (Project).Seen then
2298                In_Tree.Projects.Table (Project).Seen := True;
2299
2300                declare
2301                   Data : constant Project_Data :=
2302                     In_Tree.Projects.Table (Project);
2303                   List : Project_List := Data.Imported_Projects;
2304
2305                begin
2306                   if Process_Source_Dirs then
2307
2308                      --  Add to path all source directories of this project if
2309                      --  there are Ada sources.
2310
2311                      if In_Tree.Projects.Table (Project).Ada_Sources /=
2312                         Nil_String
2313                      then
2314                         Add_To_Source_Path (Data.Source_Dirs, In_Tree);
2315                      end if;
2316                   end if;
2317
2318                   if Process_Object_Dirs then
2319
2320                      --  Add to path the object directory of this project
2321                      --  except if we don't include library project and this
2322                      --  is a library project.
2323
2324                      if (Data.Library and then Including_Libraries)
2325                        or else
2326                          (Data.Object_Directory /= No_Path
2327                           and then
2328                             (not Including_Libraries or else not Data.Library))
2329                      then
2330                         --  For a library project, add the library ALI
2331                         --  directory if there is no object directory or
2332                         --  if the library ALI directory contains ALI files;
2333                         --  otherwise add the object directory.
2334
2335                         if Data.Library then
2336                            if Data.Object_Directory = No_Path
2337                              or else Contains_ALI_Files (Data.Library_ALI_Dir)
2338                            then
2339                               Add_To_Object_Path
2340                                 (Data.Library_ALI_Dir, In_Tree);
2341                            else
2342                               Add_To_Object_Path
2343                                 (Data.Object_Directory, In_Tree);
2344                            end if;
2345
2346                         --  For a non-library project, add the object
2347                         --  directory, if it is not a virtual project, and if
2348                         --  there are Ada sources or if the project is an
2349                         --  extending project. if There Are No Ada sources,
2350                         --  adding the object directory could disrupt the order
2351                         --  of the object dirs in the path.
2352
2353                         elsif not Data.Virtual
2354                           and then There_Are_Ada_Sources (In_Tree, Project)
2355                         then
2356                            Add_To_Object_Path
2357                              (Data.Object_Directory, In_Tree);
2358                         end if;
2359                      end if;
2360                   end if;
2361
2362                   --  Call Add to the project being extended, if any
2363
2364                   if Data.Extends /= No_Project then
2365                      Recursive_Add (Data.Extends);
2366                   end if;
2367
2368                   --  Call Add for each imported project, if any
2369
2370                   while List /= Empty_Project_List loop
2371                      Recursive_Add
2372                        (In_Tree.Project_Lists.Table
2373                           (List).Project);
2374                      List :=
2375                        In_Tree.Project_Lists.Table (List).Next;
2376                   end loop;
2377                end;
2378             end if;
2379          end Recursive_Add;
2380
2381       begin
2382          Source_Path_Table.Set_Last (In_Tree.Private_Part.Source_Paths, 0);
2383          Object_Path_Table.Set_Last (In_Tree.Private_Part.Object_Paths, 0);
2384
2385          for Index in Project_Table.First ..
2386                       Project_Table.Last (In_Tree.Projects)
2387          loop
2388             In_Tree.Projects.Table (Index).Seen := False;
2389          end loop;
2390
2391          Recursive_Add (Proj);
2392       end Add;
2393
2394    --  Start of processing for Set_Ada_Paths
2395
2396    begin
2397       --  If it is the first time we call this procedure for
2398       --  this project, compute the source path and/or the object path.
2399
2400       if In_Tree.Projects.Table (Project).Include_Path_File = No_Path then
2401          Process_Source_Dirs := True;
2402          Create_New_Path_File
2403            (In_Tree, Source_FD,
2404             In_Tree.Projects.Table (Project).Include_Path_File);
2405       end if;
2406
2407       --  For the object path, we make a distinction depending on
2408       --  Including_Libraries.
2409
2410       if Including_Libraries then
2411          if In_Tree.Projects.Table
2412            (Project).Objects_Path_File_With_Libs = No_Path
2413          then
2414             Process_Object_Dirs := True;
2415             Create_New_Path_File
2416               (In_Tree, Object_FD, In_Tree.Projects.Table (Project).
2417                                            Objects_Path_File_With_Libs);
2418          end if;
2419
2420       else
2421          if In_Tree.Projects.Table
2422               (Project).Objects_Path_File_Without_Libs = No_Path
2423          then
2424             Process_Object_Dirs := True;
2425             Create_New_Path_File
2426               (In_Tree, Object_FD, In_Tree.Projects.Table (Project).
2427                                            Objects_Path_File_Without_Libs);
2428          end if;
2429       end if;
2430
2431       --  If there is something to do, set Seen to False for all projects,
2432       --  then call the recursive procedure Add for Project.
2433
2434       if Process_Source_Dirs or Process_Object_Dirs then
2435          Add (Project);
2436       end if;
2437
2438       --  Write and close any file that has been created
2439
2440       if Source_FD /= Invalid_FD then
2441          for Index in Source_Path_Table.First ..
2442                       Source_Path_Table.Last
2443                         (In_Tree.Private_Part.Source_Paths)
2444          loop
2445             Get_Name_String (In_Tree.Private_Part.Source_Paths.Table (Index));
2446             Name_Len := Name_Len + 1;
2447             Name_Buffer (Name_Len) := ASCII.LF;
2448             Len := Write (Source_FD, Name_Buffer (1)'Address, Name_Len);
2449
2450             if Len /= Name_Len then
2451                Prj.Com.Fail ("disk full");
2452             end if;
2453          end loop;
2454
2455          Close (Source_FD, Status);
2456
2457          if not Status then
2458             Prj.Com.Fail ("disk full");
2459          end if;
2460       end if;
2461
2462       if Object_FD /= Invalid_FD then
2463          for Index in Object_Path_Table.First ..
2464                       Object_Path_Table.Last
2465                         (In_Tree.Private_Part.Object_Paths)
2466          loop
2467             Get_Name_String (In_Tree.Private_Part.Object_Paths.Table (Index));
2468             Name_Len := Name_Len + 1;
2469             Name_Buffer (Name_Len) := ASCII.LF;
2470             Len := Write (Object_FD, Name_Buffer (1)'Address, Name_Len);
2471
2472             if Len /= Name_Len then
2473                Prj.Com.Fail ("disk full");
2474             end if;
2475          end loop;
2476
2477          Close (Object_FD, Status);
2478
2479          if not Status then
2480             Prj.Com.Fail ("disk full");
2481          end if;
2482       end if;
2483
2484       --  Set the env vars, if they need to be changed, and set the
2485       --  corresponding flags.
2486
2487       if Current_Source_Path_File /=
2488            In_Tree.Projects.Table (Project).Include_Path_File
2489       then
2490          Current_Source_Path_File :=
2491            In_Tree.Projects.Table (Project).Include_Path_File;
2492          Set_Path_File_Var
2493            (Project_Include_Path_File,
2494             Get_Name_String (Current_Source_Path_File));
2495          Ada_Prj_Include_File_Set := True;
2496       end if;
2497
2498       if Including_Libraries then
2499          if Current_Object_Path_File
2500            /= In_Tree.Projects.Table
2501                 (Project).Objects_Path_File_With_Libs
2502          then
2503             Current_Object_Path_File :=
2504               In_Tree.Projects.Table
2505                 (Project).Objects_Path_File_With_Libs;
2506             Set_Path_File_Var
2507               (Project_Objects_Path_File,
2508                Get_Name_String (Current_Object_Path_File));
2509             Ada_Prj_Objects_File_Set := True;
2510          end if;
2511
2512       else
2513          if Current_Object_Path_File /=
2514            In_Tree.Projects.Table
2515              (Project).Objects_Path_File_Without_Libs
2516          then
2517             Current_Object_Path_File :=
2518               In_Tree.Projects.Table
2519                 (Project).Objects_Path_File_Without_Libs;
2520             Set_Path_File_Var
2521               (Project_Objects_Path_File,
2522                Get_Name_String (Current_Object_Path_File));
2523             Ada_Prj_Objects_File_Set := True;
2524          end if;
2525       end if;
2526    end Set_Ada_Paths;
2527
2528    ---------------------------------------------
2529    -- Set_Mapping_File_Initial_State_To_Empty --
2530    ---------------------------------------------
2531
2532    procedure Set_Mapping_File_Initial_State_To_Empty is
2533    begin
2534       Fill_Mapping_File := False;
2535    end Set_Mapping_File_Initial_State_To_Empty;
2536
2537    -----------------------
2538    -- Set_Path_File_Var --
2539    -----------------------
2540
2541    procedure Set_Path_File_Var (Name : String; Value : String) is
2542       Host_Spec : String_Access := To_Host_File_Spec (Value);
2543
2544    begin
2545       if Host_Spec = null then
2546          Prj.Com.Fail
2547            ("could not convert file name """, Value, """ to host spec");
2548       else
2549          Setenv (Name, Host_Spec.all);
2550          Free (Host_Spec);
2551       end if;
2552    end Set_Path_File_Var;
2553
2554    -----------------------
2555    -- Spec_Path_Name_Of --
2556    -----------------------
2557
2558    function Spec_Path_Name_Of
2559      (Unit : Unit_Index; In_Tree : Project_Tree_Ref) return String
2560    is
2561       Data : Unit_Data := In_Tree.Units.Table (Unit);
2562
2563    begin
2564       if Data.File_Names (Specification).Path = No_Path then
2565          declare
2566             Current_Source : String_List_Id :=
2567               In_Tree.Projects.Table
2568                 (Data.File_Names (Specification).Project).Ada_Sources;
2569             Path : GNAT.OS_Lib.String_Access;
2570
2571          begin
2572             Data.File_Names (Specification).Path :=
2573               Path_Name_Type (Data.File_Names (Specification).Name);
2574
2575             while Current_Source /= Nil_String loop
2576                Path := Locate_Regular_File
2577                  (Namet.Get_Name_String
2578                   (Data.File_Names (Specification).Name),
2579                   Namet.Get_Name_String
2580                     (In_Tree.String_Elements.Table
2581                        (Current_Source).Value));
2582
2583                if Path /= null then
2584                   Name_Len := Path'Length;
2585                   Name_Buffer (1 .. Name_Len) := Path.all;
2586                   Data.File_Names (Specification).Path := Name_Enter;
2587                   exit;
2588                else
2589                   Current_Source :=
2590                     In_Tree.String_Elements.Table
2591                       (Current_Source).Next;
2592                end if;
2593             end loop;
2594
2595             In_Tree.Units.Table (Unit) := Data;
2596          end;
2597       end if;
2598
2599       return Namet.Get_Name_String (Data.File_Names (Specification).Path);
2600    end Spec_Path_Name_Of;
2601
2602    ---------------------------
2603    -- Ultimate_Extension_Of --
2604    ---------------------------
2605
2606    function Ultimate_Extension_Of
2607      (Project : Project_Id;
2608       In_Tree : Project_Tree_Ref) return Project_Id
2609    is
2610       Result : Project_Id := Project;
2611
2612    begin
2613       while In_Tree.Projects.Table (Result).Extended_By /=
2614         No_Project
2615       loop
2616          Result := In_Tree.Projects.Table (Result).Extended_By;
2617       end loop;
2618
2619       return Result;
2620    end Ultimate_Extension_Of;
2621
2622 end Prj.Env;