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
1335                  and then not Src_Data.Locally_Removed
1336                  and then Src_Data.Replaced_By = No_Source
1337                  and then Src_Data.Path /= No_Path
1338                then
1339                   if Src_Data.Unit /= No_Name then
1340                      Get_Name_String (Src_Data.Unit);
1341
1342                      if Src_Data.Kind = Spec then
1343                         Suffix :=
1344                           In_Tree.Languages_Data.Table
1345                             (Src_Data.Language).Config.Mapping_Spec_Suffix;
1346                      else
1347                         Suffix :=
1348                           In_Tree.Languages_Data.Table
1349                             (Src_Data.Language).Config.Mapping_Body_Suffix;
1350                      end if;
1351
1352                      if Suffix /= No_File then
1353                         Add_Str_To_Name_Buffer (Get_Name_String (Suffix));
1354                      end if;
1355
1356                      Put_Name_Buffer;
1357                   end if;
1358
1359                   Get_Name_String (Src_Data.File);
1360                   Put_Name_Buffer;
1361
1362                   Get_Name_String (Src_Data.Path);
1363                   Put_Name_Buffer;
1364                end if;
1365
1366                Source := Src_Data.Next_In_Project;
1367             end loop;
1368          end if;
1369       end loop;
1370
1371       GNAT.OS_Lib.Close (File, Status);
1372
1373       if not Status then
1374          Prj.Com.Fail ("disk full");
1375       end if;
1376    end Create_Mapping_File;
1377
1378    --------------------------
1379    -- Create_New_Path_File --
1380    --------------------------
1381
1382    procedure Create_New_Path_File
1383      (In_Tree   : Project_Tree_Ref;
1384       Path_FD   : out File_Descriptor;
1385       Path_Name : out Path_Name_Type)
1386    is
1387    begin
1388       Tempdir.Create_Temp_File (Path_FD, Path_Name);
1389
1390       if Path_Name /= No_Path then
1391          Record_Temp_File (Path_Name);
1392
1393          --  Record the name, so that the temp path file will be deleted at the
1394          --  end of the program.
1395
1396          Path_File_Table.Increment_Last (In_Tree.Private_Part.Path_Files);
1397          In_Tree.Private_Part.Path_Files.Table
1398            (Path_File_Table.Last (In_Tree.Private_Part.Path_Files)) :=
1399               Path_Name;
1400       end if;
1401    end Create_New_Path_File;
1402
1403    ---------------------------
1404    -- Delete_All_Path_Files --
1405    ---------------------------
1406
1407    procedure Delete_All_Path_Files (In_Tree : Project_Tree_Ref) is
1408       Disregard : Boolean := True;
1409       pragma Warnings (Off, Disregard);
1410
1411    begin
1412       for Index in Path_File_Table.First ..
1413                    Path_File_Table.Last (In_Tree.Private_Part.Path_Files)
1414       loop
1415          if In_Tree.Private_Part.Path_Files.Table (Index) /= No_Path then
1416             Delete_File
1417               (Get_Name_String
1418                  (In_Tree.Private_Part.Path_Files.Table (Index)),
1419                Disregard);
1420          end if;
1421       end loop;
1422
1423       --  If any of the environment variables ADA_PRJ_INCLUDE_FILE or
1424       --  ADA_PRJ_OBJECTS_FILE has been set, then reset their value to
1425       --  the empty string. On VMS, this has the effect of deassigning
1426       --  the logical names.
1427
1428       if Ada_Prj_Include_File_Set then
1429          Setenv (Project_Include_Path_File, "");
1430          Ada_Prj_Include_File_Set := False;
1431       end if;
1432
1433       if Ada_Prj_Objects_File_Set then
1434          Setenv (Project_Objects_Path_File, "");
1435          Ada_Prj_Objects_File_Set := False;
1436       end if;
1437    end Delete_All_Path_Files;
1438
1439    ------------------------------------
1440    -- File_Name_Of_Library_Unit_Body --
1441    ------------------------------------
1442
1443    function File_Name_Of_Library_Unit_Body
1444      (Name              : String;
1445       Project           : Project_Id;
1446       In_Tree           : Project_Tree_Ref;
1447       Main_Project_Only : Boolean := True;
1448       Full_Path         : Boolean := False) return String
1449    is
1450       The_Project   : Project_Id := Project;
1451       Data          : Project_Data :=
1452                         In_Tree.Projects.Table (Project);
1453       Original_Name : String := Name;
1454
1455       Extended_Spec_Name : String :=
1456                              Name &
1457                              Spec_Suffix_Of (In_Tree, "ada", Data.Naming);
1458       Extended_Body_Name : String :=
1459                              Name &
1460                              Body_Suffix_Of (In_Tree, "ada", Data.Naming);
1461
1462       Unit : Unit_Data;
1463
1464       The_Original_Name : Name_Id;
1465       The_Spec_Name     : Name_Id;
1466       The_Body_Name     : Name_Id;
1467
1468    begin
1469       Canonical_Case_File_Name (Original_Name);
1470       Name_Len := Original_Name'Length;
1471       Name_Buffer (1 .. Name_Len) := Original_Name;
1472       The_Original_Name := Name_Find;
1473
1474       Canonical_Case_File_Name (Extended_Spec_Name);
1475       Name_Len := Extended_Spec_Name'Length;
1476       Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
1477       The_Spec_Name := Name_Find;
1478
1479       Canonical_Case_File_Name (Extended_Body_Name);
1480       Name_Len := Extended_Body_Name'Length;
1481       Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
1482       The_Body_Name := Name_Find;
1483
1484       if Current_Verbosity = High then
1485          Write_Str  ("Looking for file name of """);
1486          Write_Str  (Name);
1487          Write_Char ('"');
1488          Write_Eol;
1489          Write_Str  ("   Extended Spec Name = """);
1490          Write_Str  (Extended_Spec_Name);
1491          Write_Char ('"');
1492          Write_Eol;
1493          Write_Str  ("   Extended Body Name = """);
1494          Write_Str  (Extended_Body_Name);
1495          Write_Char ('"');
1496          Write_Eol;
1497       end if;
1498
1499       --  For extending project, search in the extended project if the source
1500       --  is not found. For non extending projects, this loop will be run only
1501       --  once.
1502
1503       loop
1504          --  Loop through units
1505          --  Should have comment explaining reverse ???
1506
1507          for Current in reverse Unit_Table.First ..
1508                                 Unit_Table.Last (In_Tree.Units)
1509          loop
1510             Unit := In_Tree.Units.Table (Current);
1511
1512             --  Check for body
1513
1514             if not Main_Project_Only
1515               or else Unit.File_Names (Body_Part).Project = The_Project
1516             then
1517                declare
1518                   Current_Name : constant File_Name_Type :=
1519                                    Unit.File_Names (Body_Part).Name;
1520
1521                begin
1522                   --  Case of a body present
1523
1524                   if Current_Name /= No_File then
1525                      if Current_Verbosity = High then
1526                         Write_Str  ("   Comparing with """);
1527                         Write_Str  (Get_Name_String (Current_Name));
1528                         Write_Char ('"');
1529                         Write_Eol;
1530                      end if;
1531
1532                      --  If it has the name of the original name, return the
1533                      --  original name.
1534
1535                      if Unit.Name = The_Original_Name
1536                        or else
1537                          Current_Name = File_Name_Type (The_Original_Name)
1538                      then
1539                         if Current_Verbosity = High then
1540                            Write_Line ("   OK");
1541                         end if;
1542
1543                         if Full_Path then
1544                            return Get_Name_String
1545                              (Unit.File_Names (Body_Part).Path);
1546
1547                         else
1548                            return Get_Name_String (Current_Name);
1549                         end if;
1550
1551                         --  If it has the name of the extended body name,
1552                         --  return the extended body name
1553
1554                      elsif Current_Name = File_Name_Type (The_Body_Name) then
1555                         if Current_Verbosity = High then
1556                            Write_Line ("   OK");
1557                         end if;
1558
1559                         if Full_Path then
1560                            return Get_Name_String
1561                              (Unit.File_Names (Body_Part).Path);
1562
1563                         else
1564                            return Extended_Body_Name;
1565                         end if;
1566
1567                      else
1568                         if Current_Verbosity = High then
1569                            Write_Line ("   not good");
1570                         end if;
1571                      end if;
1572                   end if;
1573                end;
1574             end if;
1575
1576             --  Check for spec
1577
1578             if not Main_Project_Only
1579               or else Unit.File_Names (Specification).Project = The_Project
1580             then
1581                declare
1582                   Current_Name : constant File_Name_Type :=
1583                                    Unit.File_Names (Specification).Name;
1584
1585                begin
1586                   --  Case of spec present
1587
1588                   if Current_Name /= No_File then
1589                      if Current_Verbosity = High then
1590                         Write_Str  ("   Comparing with """);
1591                         Write_Str  (Get_Name_String (Current_Name));
1592                         Write_Char ('"');
1593                         Write_Eol;
1594                      end if;
1595
1596                      --  If name same as original name, return original name
1597
1598                      if Unit.Name = The_Original_Name
1599                        or else
1600                          Current_Name = File_Name_Type (The_Original_Name)
1601                      then
1602                         if Current_Verbosity = High then
1603                            Write_Line ("   OK");
1604                         end if;
1605
1606                         if Full_Path then
1607                            return Get_Name_String
1608                              (Unit.File_Names (Specification).Path);
1609                         else
1610                            return Get_Name_String (Current_Name);
1611                         end if;
1612
1613                         --  If it has the same name as the extended spec name,
1614                         --  return the extended spec name.
1615
1616                      elsif Current_Name = File_Name_Type (The_Spec_Name) then
1617                         if Current_Verbosity = High then
1618                            Write_Line ("   OK");
1619                         end if;
1620
1621                         if Full_Path then
1622                            return Get_Name_String
1623                              (Unit.File_Names (Specification).Path);
1624                         else
1625                            return Extended_Spec_Name;
1626                         end if;
1627
1628                      else
1629                         if Current_Verbosity = High then
1630                            Write_Line ("   not good");
1631                         end if;
1632                      end if;
1633                   end if;
1634                end;
1635             end if;
1636          end loop;
1637
1638          --  If we are not in an extending project, give up
1639
1640          exit when (not Main_Project_Only) or else Data.Extends = No_Project;
1641
1642          --  Otherwise, look in the project we are extending
1643
1644          The_Project := Data.Extends;
1645          Data := In_Tree.Projects.Table (The_Project);
1646       end loop;
1647
1648       --  We don't know this file name, return an empty string
1649
1650       return "";
1651    end File_Name_Of_Library_Unit_Body;
1652
1653    -------------------------
1654    -- For_All_Object_Dirs --
1655    -------------------------
1656
1657    procedure For_All_Object_Dirs
1658      (Project : Project_Id;
1659       In_Tree : Project_Tree_Ref)
1660    is
1661       Seen : Project_List := Empty_Project_List;
1662
1663       procedure Add (Project : Project_Id);
1664       --  Process a project. Remember the processes visited to avoid processing
1665       --  a project twice. Recursively process an eventual extended project,
1666       --  and all imported projects.
1667
1668       ---------
1669       -- Add --
1670       ---------
1671
1672       procedure Add (Project : Project_Id) is
1673          Data : constant Project_Data :=
1674                   In_Tree.Projects.Table (Project);
1675          List : Project_List := Data.Imported_Projects;
1676
1677       begin
1678          --  If the list of visited project is empty, then
1679          --  for sure we never visited this project.
1680
1681          if Seen = Empty_Project_List then
1682             Project_List_Table.Increment_Last (In_Tree.Project_Lists);
1683             Seen := Project_List_Table.Last (In_Tree.Project_Lists);
1684             In_Tree.Project_Lists.Table (Seen) :=
1685               (Project => Project, Next => Empty_Project_List);
1686
1687          else
1688             --  Check if the project is in the list
1689
1690             declare
1691                Current : Project_List := Seen;
1692
1693             begin
1694                loop
1695                   --  If it is, then there is nothing else to do
1696
1697                   if In_Tree.Project_Lists.Table
1698                                            (Current).Project = Project
1699                   then
1700                      return;
1701                   end if;
1702
1703                   exit when
1704                     In_Tree.Project_Lists.Table (Current).Next =
1705                       Empty_Project_List;
1706                   Current :=
1707                     In_Tree.Project_Lists.Table (Current).Next;
1708                end loop;
1709
1710                --  This project has never been visited, add it
1711                --  to the list.
1712
1713                Project_List_Table.Increment_Last
1714                  (In_Tree.Project_Lists);
1715                In_Tree.Project_Lists.Table (Current).Next :=
1716                  Project_List_Table.Last (In_Tree.Project_Lists);
1717                In_Tree.Project_Lists.Table
1718                  (Project_List_Table.Last
1719                     (In_Tree.Project_Lists)) :=
1720                  (Project => Project, Next => Empty_Project_List);
1721             end;
1722          end if;
1723
1724          --  If there is an object directory, call Action with its name
1725
1726          if Data.Object_Directory /= No_Path then
1727             Get_Name_String (Data.Display_Object_Dir);
1728             Action (Name_Buffer (1 .. Name_Len));
1729          end if;
1730
1731          --  If we are extending a project, visit it
1732
1733          if Data.Extends /= No_Project then
1734             Add (Data.Extends);
1735          end if;
1736
1737          --  And visit all imported projects
1738
1739          while List /= Empty_Project_List loop
1740             Add (In_Tree.Project_Lists.Table (List).Project);
1741             List := In_Tree.Project_Lists.Table (List).Next;
1742          end loop;
1743       end Add;
1744
1745    --  Start of processing for For_All_Object_Dirs
1746
1747    begin
1748       --  Visit this project, and its imported projects, recursively
1749
1750       Add (Project);
1751    end For_All_Object_Dirs;
1752
1753    -------------------------
1754    -- For_All_Source_Dirs --
1755    -------------------------
1756
1757    procedure For_All_Source_Dirs
1758      (Project : Project_Id;
1759       In_Tree : Project_Tree_Ref)
1760    is
1761       Seen : Project_List := Empty_Project_List;
1762
1763       procedure Add (Project : Project_Id);
1764       --  Process a project. Remember the processes visited to avoid processing
1765       --  a project twice. Recursively process an eventual extended project,
1766       --  and all imported projects.
1767
1768       ---------
1769       -- Add --
1770       ---------
1771
1772       procedure Add (Project : Project_Id) is
1773          Data : constant Project_Data :=
1774                   In_Tree.Projects.Table (Project);
1775          List : Project_List := Data.Imported_Projects;
1776
1777       begin
1778          --  If the list of visited project is empty, then for sure we never
1779          --  visited this project.
1780
1781          if Seen = Empty_Project_List then
1782             Project_List_Table.Increment_Last
1783               (In_Tree.Project_Lists);
1784             Seen := Project_List_Table.Last
1785                                          (In_Tree.Project_Lists);
1786             In_Tree.Project_Lists.Table (Seen) :=
1787               (Project => Project, Next => Empty_Project_List);
1788
1789          else
1790             --  Check if the project is in the list
1791
1792             declare
1793                Current : Project_List := Seen;
1794
1795             begin
1796                loop
1797                   --  If it is, then there is nothing else to do
1798
1799                   if In_Tree.Project_Lists.Table
1800                                            (Current).Project = Project
1801                   then
1802                      return;
1803                   end if;
1804
1805                   exit when
1806                     In_Tree.Project_Lists.Table (Current).Next =
1807                       Empty_Project_List;
1808                   Current :=
1809                     In_Tree.Project_Lists.Table (Current).Next;
1810                end loop;
1811
1812                --  This project has never been visited, add it to the list
1813
1814                Project_List_Table.Increment_Last
1815                  (In_Tree.Project_Lists);
1816                In_Tree.Project_Lists.Table (Current).Next :=
1817                  Project_List_Table.Last (In_Tree.Project_Lists);
1818                In_Tree.Project_Lists.Table
1819                  (Project_List_Table.Last
1820                     (In_Tree.Project_Lists)) :=
1821                  (Project => Project, Next => Empty_Project_List);
1822             end;
1823          end if;
1824
1825          declare
1826             Current    : String_List_Id := Data.Source_Dirs;
1827             The_String : String_Element;
1828
1829          begin
1830             --  If there are Ada sources, call action with the name of every
1831             --  source directory.
1832
1833             if
1834               In_Tree.Projects.Table (Project).Ada_Sources /= Nil_String
1835             then
1836                while Current /= Nil_String loop
1837                   The_String :=
1838                     In_Tree.String_Elements.Table (Current);
1839                   Action (Get_Name_String (The_String.Display_Value));
1840                   Current := The_String.Next;
1841                end loop;
1842             end if;
1843          end;
1844
1845          --  If we are extending a project, visit it
1846
1847          if Data.Extends /= No_Project then
1848             Add (Data.Extends);
1849          end if;
1850
1851          --  And visit all imported projects
1852
1853          while List /= Empty_Project_List loop
1854             Add (In_Tree.Project_Lists.Table (List).Project);
1855             List := In_Tree.Project_Lists.Table (List).Next;
1856          end loop;
1857       end Add;
1858
1859    --  Start of processing for For_All_Source_Dirs
1860
1861    begin
1862       --  Visit this project, and its imported projects recursively
1863
1864       Add (Project);
1865    end For_All_Source_Dirs;
1866
1867    -------------------
1868    -- Get_Reference --
1869    -------------------
1870
1871    procedure Get_Reference
1872      (Source_File_Name : String;
1873       In_Tree          : Project_Tree_Ref;
1874       Project          : out Project_Id;
1875       Path             : out Path_Name_Type)
1876    is
1877    begin
1878       --  Body below could use some comments ???
1879
1880       if Current_Verbosity > Default then
1881          Write_Str ("Getting Reference_Of (""");
1882          Write_Str (Source_File_Name);
1883          Write_Str (""") ... ");
1884       end if;
1885
1886       declare
1887          Original_Name : String := Source_File_Name;
1888          Unit          : Unit_Data;
1889
1890       begin
1891          Canonical_Case_File_Name (Original_Name);
1892
1893          for Id in Unit_Table.First ..
1894                    Unit_Table.Last (In_Tree.Units)
1895          loop
1896             Unit := In_Tree.Units.Table (Id);
1897
1898             if (Unit.File_Names (Specification).Name /= No_File
1899                  and then
1900                    Namet.Get_Name_String
1901                      (Unit.File_Names (Specification).Name) = Original_Name)
1902               or else (Unit.File_Names (Specification).Path /= No_Path
1903                          and then
1904                            Namet.Get_Name_String
1905                            (Unit.File_Names (Specification).Path) =
1906                                                               Original_Name)
1907             then
1908                Project := Ultimate_Extension_Of
1909                            (Project => Unit.File_Names (Specification).Project,
1910                             In_Tree => In_Tree);
1911                Path := Unit.File_Names (Specification).Display_Path;
1912
1913                if Current_Verbosity > Default then
1914                   Write_Str ("Done: Specification.");
1915                   Write_Eol;
1916                end if;
1917
1918                return;
1919
1920             elsif (Unit.File_Names (Body_Part).Name /= No_File
1921                     and then
1922                       Namet.Get_Name_String
1923                         (Unit.File_Names (Body_Part).Name) = Original_Name)
1924               or else (Unit.File_Names (Body_Part).Path /= No_Path
1925                          and then Namet.Get_Name_String
1926                                     (Unit.File_Names (Body_Part).Path) =
1927                                                              Original_Name)
1928             then
1929                Project := Ultimate_Extension_Of
1930                             (Project => Unit.File_Names (Body_Part).Project,
1931                              In_Tree => In_Tree);
1932                Path := Unit.File_Names (Body_Part).Display_Path;
1933
1934                if Current_Verbosity > Default then
1935                   Write_Str ("Done: Body.");
1936                   Write_Eol;
1937                end if;
1938
1939                return;
1940             end if;
1941          end loop;
1942       end;
1943
1944       Project := No_Project;
1945       Path    := No_Path;
1946
1947       if Current_Verbosity > Default then
1948          Write_Str ("Cannot be found.");
1949          Write_Eol;
1950       end if;
1951    end Get_Reference;
1952
1953    ----------------
1954    -- Initialize --
1955    ----------------
1956
1957    procedure Initialize is
1958    begin
1959       Fill_Mapping_File := True;
1960       Current_Source_Path_File := No_Path;
1961       Current_Object_Path_File := No_Path;
1962    end Initialize;
1963
1964    ------------------------------------
1965    -- Path_Name_Of_Library_Unit_Body --
1966    ------------------------------------
1967
1968    --  Could use some comments in the body here ???
1969
1970    function Path_Name_Of_Library_Unit_Body
1971      (Name    : String;
1972       Project : Project_Id;
1973       In_Tree : Project_Tree_Ref) return String
1974    is
1975       Data          : constant Project_Data :=
1976                         In_Tree.Projects.Table (Project);
1977       Original_Name : String := Name;
1978
1979       Extended_Spec_Name : String :=
1980                              Name &
1981                              Spec_Suffix_Of (In_Tree, "ada", Data.Naming);
1982       Extended_Body_Name : String :=
1983                              Name &
1984                              Body_Suffix_Of (In_Tree, "ada", Data.Naming);
1985
1986       First   : Unit_Index := Unit_Table.First;
1987       Current : Unit_Index;
1988       Unit    : Unit_Data;
1989
1990    begin
1991       Canonical_Case_File_Name (Original_Name);
1992       Canonical_Case_File_Name (Extended_Spec_Name);
1993       Canonical_Case_File_Name (Extended_Body_Name);
1994
1995       if Current_Verbosity = High then
1996          Write_Str  ("Looking for path name of """);
1997          Write_Str  (Name);
1998          Write_Char ('"');
1999          Write_Eol;
2000          Write_Str  ("   Extended Spec Name = """);
2001          Write_Str  (Extended_Spec_Name);
2002          Write_Char ('"');
2003          Write_Eol;
2004          Write_Str  ("   Extended Body Name = """);
2005          Write_Str  (Extended_Body_Name);
2006          Write_Char ('"');
2007          Write_Eol;
2008       end if;
2009
2010       while First <= Unit_Table.Last (In_Tree.Units)
2011         and then In_Tree.Units.Table
2012                    (First).File_Names (Body_Part).Project /= Project
2013       loop
2014          First := First + 1;
2015       end loop;
2016
2017       Current := First;
2018       while Current <= Unit_Table.Last (In_Tree.Units) loop
2019          Unit := In_Tree.Units.Table (Current);
2020
2021          if Unit.File_Names (Body_Part).Project = Project
2022            and then Unit.File_Names (Body_Part).Name /= No_File
2023          then
2024             declare
2025                Current_Name : constant String :=
2026                  Namet.Get_Name_String (Unit.File_Names (Body_Part).Name);
2027             begin
2028                if Current_Verbosity = High then
2029                   Write_Str  ("   Comparing with """);
2030                   Write_Str  (Current_Name);
2031                   Write_Char ('"');
2032                   Write_Eol;
2033                end if;
2034
2035                if Current_Name = Original_Name then
2036                   if Current_Verbosity = High then
2037                      Write_Line ("   OK");
2038                   end if;
2039
2040                   return Body_Path_Name_Of (Current, In_Tree);
2041
2042                elsif Current_Name = Extended_Body_Name then
2043                   if Current_Verbosity = High then
2044                      Write_Line ("   OK");
2045                   end if;
2046
2047                   return Body_Path_Name_Of (Current, In_Tree);
2048
2049                else
2050                   if Current_Verbosity = High then
2051                      Write_Line ("   not good");
2052                   end if;
2053                end if;
2054             end;
2055
2056          elsif Unit.File_Names (Specification).Name /= No_File then
2057             declare
2058                Current_Name : constant String :=
2059                                 Namet.Get_Name_String
2060                                   (Unit.File_Names (Specification).Name);
2061
2062             begin
2063                if Current_Verbosity = High then
2064                   Write_Str  ("   Comparing with """);
2065                   Write_Str  (Current_Name);
2066                   Write_Char ('"');
2067                   Write_Eol;
2068                end if;
2069
2070                if Current_Name = Original_Name then
2071                   if Current_Verbosity = High then
2072                      Write_Line ("   OK");
2073                   end if;
2074
2075                   return Spec_Path_Name_Of (Current, In_Tree);
2076
2077                elsif Current_Name = Extended_Spec_Name then
2078                   if Current_Verbosity = High then
2079                      Write_Line ("   OK");
2080                   end if;
2081
2082                   return Spec_Path_Name_Of (Current, In_Tree);
2083
2084                else
2085                   if Current_Verbosity = High then
2086                      Write_Line ("   not good");
2087                   end if;
2088                end if;
2089             end;
2090          end if;
2091          Current := Current + 1;
2092       end loop;
2093
2094       return "";
2095    end Path_Name_Of_Library_Unit_Body;
2096
2097    -------------------
2098    -- Print_Sources --
2099    -------------------
2100
2101    --  Could use some comments in this body ???
2102
2103    procedure Print_Sources (In_Tree : Project_Tree_Ref) is
2104       Unit : Unit_Data;
2105
2106    begin
2107       Write_Line ("List of Sources:");
2108
2109       for Id in Unit_Table.First ..
2110                 Unit_Table.Last (In_Tree.Units)
2111       loop
2112          Unit := In_Tree.Units.Table (Id);
2113          Write_Str  ("   ");
2114          Write_Line (Namet.Get_Name_String (Unit.Name));
2115
2116          if Unit.File_Names (Specification).Name /= No_File then
2117             if Unit.File_Names (Specification).Project = No_Project then
2118                Write_Line ("   No project");
2119
2120             else
2121                Write_Str  ("   Project: ");
2122                Get_Name_String
2123                  (In_Tree.Projects.Table
2124                    (Unit.File_Names (Specification).Project).Path_Name);
2125                Write_Line (Name_Buffer (1 .. Name_Len));
2126             end if;
2127
2128             Write_Str  ("      spec: ");
2129             Write_Line
2130               (Namet.Get_Name_String
2131                (Unit.File_Names (Specification).Name));
2132          end if;
2133
2134          if Unit.File_Names (Body_Part).Name /= No_File then
2135             if Unit.File_Names (Body_Part).Project = No_Project then
2136                Write_Line ("   No project");
2137
2138             else
2139                Write_Str  ("   Project: ");
2140                Get_Name_String
2141                  (In_Tree.Projects.Table
2142                    (Unit.File_Names (Body_Part).Project).Path_Name);
2143                Write_Line (Name_Buffer (1 .. Name_Len));
2144             end if;
2145
2146             Write_Str  ("      body: ");
2147             Write_Line
2148               (Namet.Get_Name_String
2149                (Unit.File_Names (Body_Part).Name));
2150          end if;
2151       end loop;
2152
2153       Write_Line ("end of List of Sources.");
2154    end Print_Sources;
2155
2156    ----------------
2157    -- Project_Of --
2158    ----------------
2159
2160    function Project_Of
2161      (Name         : String;
2162       Main_Project : Project_Id;
2163       In_Tree      : Project_Tree_Ref) return Project_Id
2164    is
2165       Result : Project_Id := No_Project;
2166
2167       Original_Name : String := Name;
2168
2169       Data   : constant Project_Data :=
2170         In_Tree.Projects.Table (Main_Project);
2171
2172       Extended_Spec_Name : String :=
2173                              Name &
2174                              Spec_Suffix_Of (In_Tree, "ada", Data.Naming);
2175       Extended_Body_Name : String :=
2176                              Name &
2177                              Body_Suffix_Of (In_Tree, "ada", Data.Naming);
2178
2179       Unit : Unit_Data;
2180
2181       Current_Name      : File_Name_Type;
2182       The_Original_Name : File_Name_Type;
2183       The_Spec_Name     : File_Name_Type;
2184       The_Body_Name     : File_Name_Type;
2185
2186    begin
2187       Canonical_Case_File_Name (Original_Name);
2188       Name_Len := Original_Name'Length;
2189       Name_Buffer (1 .. Name_Len) := Original_Name;
2190       The_Original_Name := Name_Find;
2191
2192       Canonical_Case_File_Name (Extended_Spec_Name);
2193       Name_Len := Extended_Spec_Name'Length;
2194       Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
2195       The_Spec_Name := Name_Find;
2196
2197       Canonical_Case_File_Name (Extended_Body_Name);
2198       Name_Len := Extended_Body_Name'Length;
2199       Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
2200       The_Body_Name := Name_Find;
2201
2202       for Current in reverse Unit_Table.First ..
2203                              Unit_Table.Last (In_Tree.Units)
2204       loop
2205          Unit := In_Tree.Units.Table (Current);
2206
2207          --  Check for body
2208
2209          Current_Name := Unit.File_Names (Body_Part).Name;
2210
2211          --  Case of a body present
2212
2213          if Current_Name /= No_File then
2214
2215             --  If it has the name of the original name or the body name,
2216             --  we have found the project.
2217
2218             if Unit.Name = Name_Id (The_Original_Name)
2219               or else Current_Name = The_Original_Name
2220               or else Current_Name = The_Body_Name
2221             then
2222                Result := Unit.File_Names (Body_Part).Project;
2223                exit;
2224             end if;
2225          end if;
2226
2227          --  Check for spec
2228
2229          Current_Name := Unit.File_Names (Specification).Name;
2230
2231          if Current_Name /= No_File then
2232
2233             --  If name same as the original name, or the spec name, we have
2234             --  found the project.
2235
2236             if Unit.Name = Name_Id (The_Original_Name)
2237               or else Current_Name = The_Original_Name
2238               or else Current_Name = The_Spec_Name
2239             then
2240                Result := Unit.File_Names (Specification).Project;
2241                exit;
2242             end if;
2243          end if;
2244       end loop;
2245
2246       --  Get the ultimate extending project
2247
2248       if Result /= No_Project then
2249          while In_Tree.Projects.Table (Result).Extended_By /=
2250            No_Project
2251          loop
2252             Result := In_Tree.Projects.Table (Result).Extended_By;
2253          end loop;
2254       end if;
2255
2256       return Result;
2257    end Project_Of;
2258
2259    -------------------
2260    -- Set_Ada_Paths --
2261    -------------------
2262
2263    procedure Set_Ada_Paths
2264      (Project             : Project_Id;
2265       In_Tree             : Project_Tree_Ref;
2266       Including_Libraries : Boolean)
2267    is
2268       Source_FD : File_Descriptor := Invalid_FD;
2269       Object_FD : File_Descriptor := Invalid_FD;
2270
2271       Process_Source_Dirs : Boolean := False;
2272       Process_Object_Dirs : Boolean := False;
2273
2274       Status : Boolean;
2275       --  For calls to Close
2276
2277       Len : Natural;
2278
2279       procedure Add (Proj : Project_Id);
2280       --  Add all the source/object directories of a project to the path only
2281       --  if this project has not been visited. Calls an internal procedure
2282       --  recursively for projects being extended, and imported projects.
2283
2284       ---------
2285       -- Add --
2286       ---------
2287
2288       procedure Add (Proj : Project_Id) is
2289
2290          procedure Recursive_Add (Project : Project_Id);
2291          --  Recursive procedure to add the source/object paths of extended/
2292          --  imported projects.
2293
2294          -------------------
2295          -- Recursive_Add --
2296          -------------------
2297
2298          procedure Recursive_Add (Project : Project_Id) is
2299          begin
2300             --  If Seen is False, then the project has not yet been visited
2301
2302             if not In_Tree.Projects.Table (Project).Seen then
2303                In_Tree.Projects.Table (Project).Seen := True;
2304
2305                declare
2306                   Data : constant Project_Data :=
2307                     In_Tree.Projects.Table (Project);
2308                   List : Project_List := Data.Imported_Projects;
2309
2310                begin
2311                   if Process_Source_Dirs then
2312
2313                      --  Add to path all source directories of this project if
2314                      --  there are Ada sources.
2315
2316                      if In_Tree.Projects.Table (Project).Ada_Sources /=
2317                         Nil_String
2318                      then
2319                         Add_To_Source_Path (Data.Source_Dirs, In_Tree);
2320                      end if;
2321                   end if;
2322
2323                   if Process_Object_Dirs then
2324
2325                      --  Add to path the object directory of this project
2326                      --  except if we don't include library project and this
2327                      --  is a library project.
2328
2329                      if (Data.Library and Including_Libraries)
2330                        or else
2331                          (Data.Object_Directory /= No_Path
2332                            and then
2333                             (not Including_Libraries or else not Data.Library))
2334                      then
2335                         --  For a library project, add the library ALI
2336                         --  directory if there is no object directory or
2337                         --  if the library ALI directory contains ALI files;
2338                         --  otherwise add the object directory.
2339
2340                         if Data.Library then
2341                            if Data.Object_Directory = No_Path
2342                              or else Contains_ALI_Files (Data.Library_ALI_Dir)
2343                            then
2344                               Add_To_Object_Path
2345                                 (Data.Library_ALI_Dir, In_Tree);
2346                            else
2347                               Add_To_Object_Path
2348                                 (Data.Object_Directory, In_Tree);
2349                            end if;
2350
2351                         --  For a non-library project, add the object
2352                         --  directory, if it is not a virtual project, and if
2353                         --  there are Ada sources or if the project is an
2354                         --  extending project. If there are no Ada sources,
2355                         --  adding the object directory could disrupt the order
2356                         --  of the object dirs in the path.
2357
2358                         elsif not Data.Virtual
2359                           and then There_Are_Ada_Sources (In_Tree, Project)
2360                         then
2361                            Add_To_Object_Path
2362                              (Data.Object_Directory, In_Tree);
2363                         end if;
2364                      end if;
2365                   end if;
2366
2367                   --  Call Add to the project being extended, if any
2368
2369                   if Data.Extends /= No_Project then
2370                      Recursive_Add (Data.Extends);
2371                   end if;
2372
2373                   --  Call Add for each imported project, if any
2374
2375                   while List /= Empty_Project_List loop
2376                      Recursive_Add
2377                        (In_Tree.Project_Lists.Table
2378                           (List).Project);
2379                      List :=
2380                        In_Tree.Project_Lists.Table (List).Next;
2381                   end loop;
2382                end;
2383             end if;
2384          end Recursive_Add;
2385
2386       begin
2387          Source_Path_Table.Set_Last (In_Tree.Private_Part.Source_Paths, 0);
2388          Object_Path_Table.Set_Last (In_Tree.Private_Part.Object_Paths, 0);
2389
2390          for Index in Project_Table.First ..
2391                       Project_Table.Last (In_Tree.Projects)
2392          loop
2393             In_Tree.Projects.Table (Index).Seen := False;
2394          end loop;
2395
2396          Recursive_Add (Proj);
2397       end Add;
2398
2399    --  Start of processing for Set_Ada_Paths
2400
2401    begin
2402       --  If it is the first time we call this procedure for
2403       --  this project, compute the source path and/or the object path.
2404
2405       if In_Tree.Projects.Table (Project).Include_Path_File = No_Path then
2406          Process_Source_Dirs := True;
2407          Create_New_Path_File
2408            (In_Tree, Source_FD,
2409             In_Tree.Projects.Table (Project).Include_Path_File);
2410       end if;
2411
2412       --  For the object path, we make a distinction depending on
2413       --  Including_Libraries.
2414
2415       if Including_Libraries then
2416          if In_Tree.Projects.Table
2417            (Project).Objects_Path_File_With_Libs = No_Path
2418          then
2419             Process_Object_Dirs := True;
2420             Create_New_Path_File
2421               (In_Tree, Object_FD, In_Tree.Projects.Table (Project).
2422                                            Objects_Path_File_With_Libs);
2423          end if;
2424
2425       else
2426          if In_Tree.Projects.Table
2427               (Project).Objects_Path_File_Without_Libs = No_Path
2428          then
2429             Process_Object_Dirs := True;
2430             Create_New_Path_File
2431               (In_Tree, Object_FD, In_Tree.Projects.Table (Project).
2432                                            Objects_Path_File_Without_Libs);
2433          end if;
2434       end if;
2435
2436       --  If there is something to do, set Seen to False for all projects,
2437       --  then call the recursive procedure Add for Project.
2438
2439       if Process_Source_Dirs or Process_Object_Dirs then
2440          Add (Project);
2441       end if;
2442
2443       --  Write and close any file that has been created
2444
2445       if Source_FD /= Invalid_FD then
2446          for Index in Source_Path_Table.First ..
2447                       Source_Path_Table.Last
2448                         (In_Tree.Private_Part.Source_Paths)
2449          loop
2450             Get_Name_String (In_Tree.Private_Part.Source_Paths.Table (Index));
2451             Name_Len := Name_Len + 1;
2452             Name_Buffer (Name_Len) := ASCII.LF;
2453             Len := Write (Source_FD, Name_Buffer (1)'Address, Name_Len);
2454
2455             if Len /= Name_Len then
2456                Prj.Com.Fail ("disk full");
2457             end if;
2458          end loop;
2459
2460          Close (Source_FD, Status);
2461
2462          if not Status then
2463             Prj.Com.Fail ("disk full");
2464          end if;
2465       end if;
2466
2467       if Object_FD /= Invalid_FD then
2468          for Index in Object_Path_Table.First ..
2469                       Object_Path_Table.Last
2470                         (In_Tree.Private_Part.Object_Paths)
2471          loop
2472             Get_Name_String (In_Tree.Private_Part.Object_Paths.Table (Index));
2473             Name_Len := Name_Len + 1;
2474             Name_Buffer (Name_Len) := ASCII.LF;
2475             Len := Write (Object_FD, Name_Buffer (1)'Address, Name_Len);
2476
2477             if Len /= Name_Len then
2478                Prj.Com.Fail ("disk full");
2479             end if;
2480          end loop;
2481
2482          Close (Object_FD, Status);
2483
2484          if not Status then
2485             Prj.Com.Fail ("disk full");
2486          end if;
2487       end if;
2488
2489       --  Set the env vars, if they need to be changed, and set the
2490       --  corresponding flags.
2491
2492       if Current_Source_Path_File /=
2493            In_Tree.Projects.Table (Project).Include_Path_File
2494       then
2495          Current_Source_Path_File :=
2496            In_Tree.Projects.Table (Project).Include_Path_File;
2497          Set_Path_File_Var
2498            (Project_Include_Path_File,
2499             Get_Name_String (Current_Source_Path_File));
2500          Ada_Prj_Include_File_Set := True;
2501       end if;
2502
2503       if Including_Libraries then
2504          if Current_Object_Path_File
2505            /= In_Tree.Projects.Table
2506                 (Project).Objects_Path_File_With_Libs
2507          then
2508             Current_Object_Path_File :=
2509               In_Tree.Projects.Table
2510                 (Project).Objects_Path_File_With_Libs;
2511             Set_Path_File_Var
2512               (Project_Objects_Path_File,
2513                Get_Name_String (Current_Object_Path_File));
2514             Ada_Prj_Objects_File_Set := True;
2515          end if;
2516
2517       else
2518          if Current_Object_Path_File /=
2519            In_Tree.Projects.Table
2520              (Project).Objects_Path_File_Without_Libs
2521          then
2522             Current_Object_Path_File :=
2523               In_Tree.Projects.Table
2524                 (Project).Objects_Path_File_Without_Libs;
2525             Set_Path_File_Var
2526               (Project_Objects_Path_File,
2527                Get_Name_String (Current_Object_Path_File));
2528             Ada_Prj_Objects_File_Set := True;
2529          end if;
2530       end if;
2531    end Set_Ada_Paths;
2532
2533    ---------------------------------------------
2534    -- Set_Mapping_File_Initial_State_To_Empty --
2535    ---------------------------------------------
2536
2537    procedure Set_Mapping_File_Initial_State_To_Empty is
2538    begin
2539       Fill_Mapping_File := False;
2540    end Set_Mapping_File_Initial_State_To_Empty;
2541
2542    -----------------------
2543    -- Set_Path_File_Var --
2544    -----------------------
2545
2546    procedure Set_Path_File_Var (Name : String; Value : String) is
2547       Host_Spec : String_Access := To_Host_File_Spec (Value);
2548
2549    begin
2550       if Host_Spec = null then
2551          Prj.Com.Fail
2552            ("could not convert file name """, Value, """ to host spec");
2553       else
2554          Setenv (Name, Host_Spec.all);
2555          Free (Host_Spec);
2556       end if;
2557    end Set_Path_File_Var;
2558
2559    -----------------------
2560    -- Spec_Path_Name_Of --
2561    -----------------------
2562
2563    function Spec_Path_Name_Of
2564      (Unit : Unit_Index; In_Tree : Project_Tree_Ref) return String
2565    is
2566       Data : Unit_Data := In_Tree.Units.Table (Unit);
2567
2568    begin
2569       if Data.File_Names (Specification).Path = No_Path then
2570          declare
2571             Current_Source : String_List_Id :=
2572               In_Tree.Projects.Table
2573                 (Data.File_Names (Specification).Project).Ada_Sources;
2574             Path : GNAT.OS_Lib.String_Access;
2575
2576          begin
2577             Data.File_Names (Specification).Path :=
2578               Path_Name_Type (Data.File_Names (Specification).Name);
2579
2580             while Current_Source /= Nil_String loop
2581                Path := Locate_Regular_File
2582                  (Namet.Get_Name_String
2583                   (Data.File_Names (Specification).Name),
2584                   Namet.Get_Name_String
2585                     (In_Tree.String_Elements.Table
2586                        (Current_Source).Value));
2587
2588                if Path /= null then
2589                   Name_Len := Path'Length;
2590                   Name_Buffer (1 .. Name_Len) := Path.all;
2591                   Data.File_Names (Specification).Path := Name_Enter;
2592                   exit;
2593                else
2594                   Current_Source :=
2595                     In_Tree.String_Elements.Table
2596                       (Current_Source).Next;
2597                end if;
2598             end loop;
2599
2600             In_Tree.Units.Table (Unit) := Data;
2601          end;
2602       end if;
2603
2604       return Namet.Get_Name_String (Data.File_Names (Specification).Path);
2605    end Spec_Path_Name_Of;
2606
2607    ---------------------------
2608    -- Ultimate_Extension_Of --
2609    ---------------------------
2610
2611    function Ultimate_Extension_Of
2612      (Project : Project_Id;
2613       In_Tree : Project_Tree_Ref) return Project_Id
2614    is
2615       Result : Project_Id := Project;
2616
2617    begin
2618       while In_Tree.Projects.Table (Result).Extended_By /=
2619         No_Project
2620       loop
2621          Result := In_Tree.Projects.Table (Result).Extended_By;
2622       end loop;
2623
2624       return Result;
2625    end Ultimate_Extension_Of;
2626
2627 end Prj.Env;