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 2,  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 COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  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_File --
 988    -------------------------
 989
 990    procedure Create_Mapping_File
 991      (Project : Project_Id;
 992       In_Tree : Project_Tree_Ref;
 993       Name    : out Path_Name_Type)
 994    is
 995       File          : File_Descriptor := Invalid_FD;
 996       The_Unit_Data : Unit_Data;
 997       Data          : File_Name_Data;
 998
 999       Status : Boolean;
1000       --  For call to Close
1001
1002       Present       : Project_Flags
1003         (No_Project .. Project_Table.Last (In_Tree.Projects)) :=
1004         (others => False);
1005       --  For each project in the closure of Project, the corresponding flag
1006       --  will be set to True;
1007
1008       procedure Put_Name_Buffer;
1009       --  Put the line contained in the Name_Buffer in the mapping file
1010
1011       procedure Put_Data (Spec : Boolean);
1012       --  Put the mapping of the spec or body contained in Data in the file
1013       --  (3 lines).
1014
1015       procedure Recursive_Flag (Prj : Project_Id);
1016       --  Set the flags corresponding to Prj, the projects it imports
1017       --  (directly or indirectly) or extends to True. Call itself recursively.
1018
1019       ---------
1020       -- Put --
1021       ---------
1022
1023       procedure Put_Name_Buffer is
1024          Last : Natural;
1025
1026       begin
1027          Name_Len := Name_Len + 1;
1028          Name_Buffer (Name_Len) := ASCII.LF;
1029          Last := Write (File, Name_Buffer (1)'Address, Name_Len);
1030
1031          if Last /= Name_Len then
1032             Prj.Com.Fail ("Disk full");
1033          end if;
1034       end Put_Name_Buffer;
1035
1036       --------------
1037       -- Put_Data --
1038       --------------
1039
1040       procedure Put_Data (Spec : Boolean) is
1041       begin
1042          --  Line with the unit name
1043
1044          Get_Name_String (The_Unit_Data.Name);
1045          Name_Len := Name_Len + 1;
1046          Name_Buffer (Name_Len) := '%';
1047          Name_Len := Name_Len + 1;
1048
1049          if Spec then
1050             Name_Buffer (Name_Len) := 's';
1051          else
1052             Name_Buffer (Name_Len) := 'b';
1053          end if;
1054
1055          Put_Name_Buffer;
1056
1057          --  Line with the file name
1058
1059          Get_Name_String (Data.Name);
1060          Put_Name_Buffer;
1061
1062          --  Line with the path name
1063
1064          Get_Name_String (Data.Path);
1065          Put_Name_Buffer;
1066
1067       end Put_Data;
1068
1069       --------------------
1070       -- Recursive_Flag --
1071       --------------------
1072
1073       procedure Recursive_Flag (Prj : Project_Id) is
1074          Imported : Project_List;
1075          Proj     : Project_Id;
1076
1077       begin
1078          --  Nothing to do for non existent project or project that has
1079          --  already been flagged.
1080
1081          if Prj = No_Project or else Present (Prj) then
1082             return;
1083          end if;
1084
1085          --  Flag the current project
1086
1087          Present (Prj) := True;
1088          Imported :=
1089            In_Tree.Projects.Table (Prj).Imported_Projects;
1090
1091          --  Call itself for each project directly imported
1092
1093          while Imported /= Empty_Project_List loop
1094             Proj :=
1095               In_Tree.Project_Lists.Table (Imported).Project;
1096             Imported :=
1097               In_Tree.Project_Lists.Table (Imported).Next;
1098             Recursive_Flag (Proj);
1099          end loop;
1100
1101          --  Call itself for an eventual project being extended
1102
1103          Recursive_Flag (In_Tree.Projects.Table (Prj).Extends);
1104       end Recursive_Flag;
1105
1106    --  Start of processing for Create_Mapping_File
1107
1108    begin
1109       --  Flag the necessary projects
1110
1111       Recursive_Flag (Project);
1112
1113       --  Create the temporary file
1114
1115       Tempdir.Create_Temp_File (File, Name => Name);
1116
1117       if File = Invalid_FD then
1118          Prj.Com.Fail ("unable to create temporary mapping file");
1119
1120       else
1121          Record_Temp_File (Name);
1122
1123          if Opt.Verbose_Mode then
1124             Write_Str ("Creating temp mapping file """);
1125             Write_Str (Get_Name_String (Name));
1126             Write_Line ("""");
1127          end if;
1128       end if;
1129
1130       if Fill_Mapping_File then
1131
1132          --  For all units in table Units
1133
1134          for Unit in 1 .. Unit_Table.Last (In_Tree.Units) loop
1135             The_Unit_Data := In_Tree.Units.Table (Unit);
1136
1137             --  If the unit has a valid name
1138
1139             if The_Unit_Data.Name /= No_Name then
1140                Data := The_Unit_Data.File_Names (Specification);
1141
1142                --  If there is a spec, put it mapping in the file if it is
1143                --  from a project in the closure of Project.
1144
1145                if Data.Name /= No_File and then Present (Data.Project) then
1146                   Put_Data (Spec => True);
1147                end if;
1148
1149                Data := The_Unit_Data.File_Names (Body_Part);
1150
1151                --  If there is a body (or subunit) put its mapping in the file
1152                --  if it is from a project in the closure of Project.
1153
1154                if Data.Name /= No_File and then Present (Data.Project) then
1155                   Put_Data (Spec => False);
1156                end if;
1157
1158             end if;
1159          end loop;
1160       end if;
1161
1162       GNAT.OS_Lib.Close (File, Status);
1163
1164       if not Status then
1165          Prj.Com.Fail ("disk full");
1166       end if;
1167    end Create_Mapping_File;
1168
1169    procedure Create_Mapping_File
1170      (Project  : Project_Id;
1171       Language : Name_Id;
1172       Runtime  : Project_Id;
1173       In_Tree  : Project_Tree_Ref;
1174       Name     : out Path_Name_Type)
1175    is
1176       File : File_Descriptor := Invalid_FD;
1177
1178       Status : Boolean;
1179       --  For call to Close
1180
1181       Present : Project_Flags
1182                  (No_Project .. Project_Table.Last (In_Tree.Projects)) :=
1183                    (others => False);
1184       --  For each project in the closure of Project, the corresponding flag
1185       --  will be set to True.
1186
1187       Source   : Source_Id;
1188       Src_Data : Source_Data;
1189       Suffix   : File_Name_Type;
1190
1191       procedure Put_Name_Buffer;
1192       --  Put the line contained in the Name_Buffer in the mapping file
1193
1194       procedure Recursive_Flag (Prj : Project_Id);
1195       --  Set the flags corresponding to Prj, the projects it imports
1196       --  (directly or indirectly) or extends to True. Call itself recursively.
1197
1198       ---------
1199       -- Put --
1200       ---------
1201
1202       procedure Put_Name_Buffer is
1203          Last : Natural;
1204
1205       begin
1206          Name_Len := Name_Len + 1;
1207          Name_Buffer (Name_Len) := ASCII.LF;
1208          Last := Write (File, Name_Buffer (1)'Address, Name_Len);
1209
1210          if Last /= Name_Len then
1211             Prj.Com.Fail ("Disk full");
1212          end if;
1213       end Put_Name_Buffer;
1214
1215       --------------------
1216       -- Recursive_Flag --
1217       --------------------
1218
1219       procedure Recursive_Flag (Prj : Project_Id) is
1220          Imported : Project_List;
1221          Proj     : Project_Id;
1222
1223       begin
1224          --  Nothing to do for non existent or runtime project or project
1225          --  that has already been flagged.
1226
1227          if Prj = No_Project or else Prj = Runtime or else Present (Prj) then
1228             return;
1229          end if;
1230
1231          --  Flag the current project
1232
1233          Present (Prj) := True;
1234          Imported :=
1235            In_Tree.Projects.Table (Prj).Imported_Projects;
1236
1237          --  Call itself for each project directly imported
1238
1239          while Imported /= Empty_Project_List loop
1240             Proj :=
1241               In_Tree.Project_Lists.Table (Imported).Project;
1242             Imported :=
1243               In_Tree.Project_Lists.Table (Imported).Next;
1244             Recursive_Flag (Proj);
1245          end loop;
1246
1247          --  Call itself for an eventual project being extended
1248
1249          Recursive_Flag (In_Tree.Projects.Table (Prj).Extends);
1250       end Recursive_Flag;
1251
1252    --  Start of processing for Create_Mapping_File
1253
1254    begin
1255       --  Flag the necessary projects
1256
1257       Recursive_Flag (Project);
1258
1259       --  Create the temporary file
1260
1261       Tempdir.Create_Temp_File (File, Name => Name);
1262
1263       if File = Invalid_FD then
1264          Prj.Com.Fail ("unable to create temporary mapping file");
1265
1266       else
1267          Record_Temp_File (Name);
1268
1269          if Opt.Verbose_Mode then
1270             Write_Str ("Creating temp mapping file """);
1271             Write_Str (Get_Name_String (Name));
1272             Write_Line ("""");
1273          end if;
1274       end if;
1275
1276       --  For all source of the Language of all projects in the closure
1277
1278       for Proj in Present'Range loop
1279          if Present (Proj) then
1280             Source := In_Tree.Projects.Table (Proj).First_Source;
1281
1282             while Source /= No_Source loop
1283                Src_Data := In_Tree.Sources.Table (Source);
1284
1285                if Src_Data.Language_Name = Language and then
1286                  (not Src_Data.Locally_Removed) and then
1287                  Src_Data.Replaced_By = No_Source
1288                then
1289                   if Src_Data.Unit /= No_Name then
1290                      Get_Name_String (Src_Data.Unit);
1291
1292                      if Src_Data.Kind = Spec then
1293                         Suffix := In_Tree.Languages_Data.Table
1294                           (Src_Data.Language).Config.Mapping_Spec_Suffix;
1295
1296                      else
1297                         Suffix := In_Tree.Languages_Data.Table
1298                           (Src_Data.Language).Config.Mapping_Body_Suffix;
1299                      end if;
1300
1301                      if Suffix /= No_File then
1302                         Add_Str_To_Name_Buffer (Get_Name_String (Suffix));
1303                      end if;
1304
1305                      Put_Name_Buffer;
1306                   end if;
1307
1308                   Get_Name_String (Src_Data.File);
1309                   Put_Name_Buffer;
1310
1311                   Get_Name_String (Src_Data.Path);
1312                   Put_Name_Buffer;
1313                end if;
1314
1315                Source := Src_Data.Next_In_Project;
1316             end loop;
1317          end if;
1318       end loop;
1319
1320       GNAT.OS_Lib.Close (File, Status);
1321
1322       if not Status then
1323          Prj.Com.Fail ("disk full");
1324       end if;
1325    end Create_Mapping_File;
1326
1327    --------------------------
1328    -- Create_New_Path_File --
1329    --------------------------
1330
1331    procedure Create_New_Path_File
1332      (In_Tree   : Project_Tree_Ref;
1333       Path_FD   : out File_Descriptor;
1334       Path_Name : out Path_Name_Type)
1335    is
1336    begin
1337       Tempdir.Create_Temp_File (Path_FD, Path_Name);
1338
1339       if Path_Name /= No_Path then
1340          Record_Temp_File (Path_Name);
1341
1342          --  Record the name, so that the temp path file will be deleted at the
1343          --  end of the program.
1344
1345          Path_File_Table.Increment_Last (In_Tree.Private_Part.Path_Files);
1346          In_Tree.Private_Part.Path_Files.Table
1347            (Path_File_Table.Last (In_Tree.Private_Part.Path_Files)) :=
1348               Path_Name;
1349       end if;
1350    end Create_New_Path_File;
1351
1352    ---------------------------
1353    -- Delete_All_Path_Files --
1354    ---------------------------
1355
1356    procedure Delete_All_Path_Files (In_Tree : Project_Tree_Ref) is
1357       Disregard : Boolean := True;
1358
1359    begin
1360       for Index in Path_File_Table.First ..
1361                    Path_File_Table.Last (In_Tree.Private_Part.Path_Files)
1362       loop
1363          if In_Tree.Private_Part.Path_Files.Table (Index) /= No_Path then
1364             Delete_File
1365               (Get_Name_String
1366                  (In_Tree.Private_Part.Path_Files.Table (Index)),
1367                Disregard);
1368          end if;
1369       end loop;
1370
1371       --  If any of the environment variables ADA_PRJ_INCLUDE_FILE or
1372       --  ADA_PRJ_OBJECTS_FILE has been set, then reset their value to
1373       --  the empty string. On VMS, this has the effect of deassigning
1374       --  the logical names.
1375
1376       if Ada_Prj_Include_File_Set then
1377          Setenv (Project_Include_Path_File, "");
1378          Ada_Prj_Include_File_Set := False;
1379       end if;
1380
1381       if Ada_Prj_Objects_File_Set then
1382          Setenv (Project_Objects_Path_File, "");
1383          Ada_Prj_Objects_File_Set := False;
1384       end if;
1385    end Delete_All_Path_Files;
1386
1387    ------------------------------------
1388    -- File_Name_Of_Library_Unit_Body --
1389    ------------------------------------
1390
1391    function File_Name_Of_Library_Unit_Body
1392      (Name              : String;
1393       Project           : Project_Id;
1394       In_Tree           : Project_Tree_Ref;
1395       Main_Project_Only : Boolean := True;
1396       Full_Path         : Boolean := False) return String
1397    is
1398       The_Project   : Project_Id := Project;
1399       Data          : Project_Data :=
1400                         In_Tree.Projects.Table (Project);
1401       Original_Name : String := Name;
1402
1403       Extended_Spec_Name : String :=
1404                              Name &
1405                              Spec_Suffix_Of (In_Tree, "ada", Data.Naming);
1406       Extended_Body_Name : String :=
1407                              Name &
1408                              Body_Suffix_Of (In_Tree, "ada", Data.Naming);
1409
1410       Unit : Unit_Data;
1411
1412       The_Original_Name : Name_Id;
1413       The_Spec_Name     : Name_Id;
1414       The_Body_Name     : Name_Id;
1415
1416    begin
1417       Canonical_Case_File_Name (Original_Name);
1418       Name_Len := Original_Name'Length;
1419       Name_Buffer (1 .. Name_Len) := Original_Name;
1420       The_Original_Name := Name_Find;
1421
1422       Canonical_Case_File_Name (Extended_Spec_Name);
1423       Name_Len := Extended_Spec_Name'Length;
1424       Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
1425       The_Spec_Name := Name_Find;
1426
1427       Canonical_Case_File_Name (Extended_Body_Name);
1428       Name_Len := Extended_Body_Name'Length;
1429       Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
1430       The_Body_Name := Name_Find;
1431
1432       if Current_Verbosity = High then
1433          Write_Str  ("Looking for file name of """);
1434          Write_Str  (Name);
1435          Write_Char ('"');
1436          Write_Eol;
1437          Write_Str  ("   Extended Spec Name = """);
1438          Write_Str  (Extended_Spec_Name);
1439          Write_Char ('"');
1440          Write_Eol;
1441          Write_Str  ("   Extended Body Name = """);
1442          Write_Str  (Extended_Body_Name);
1443          Write_Char ('"');
1444          Write_Eol;
1445       end if;
1446
1447       --  For extending project, search in the extended project if the source
1448       --  is not found. For non extending projects, this loop will be run only
1449       --  once.
1450
1451       loop
1452          --  Loop through units
1453          --  Should have comment explaining reverse ???
1454
1455          for Current in reverse Unit_Table.First ..
1456                                 Unit_Table.Last (In_Tree.Units)
1457          loop
1458             Unit := In_Tree.Units.Table (Current);
1459
1460             --  Check for body
1461
1462             if not Main_Project_Only
1463               or else Unit.File_Names (Body_Part).Project = The_Project
1464             then
1465                declare
1466                   Current_Name : constant File_Name_Type :=
1467                                    Unit.File_Names (Body_Part).Name;
1468
1469                begin
1470                   --  Case of a body present
1471
1472                   if Current_Name /= No_File then
1473                      if Current_Verbosity = High then
1474                         Write_Str  ("   Comparing with """);
1475                         Write_Str  (Get_Name_String (Current_Name));
1476                         Write_Char ('"');
1477                         Write_Eol;
1478                      end if;
1479
1480                      --  If it has the name of the original name, return the
1481                      --  original name.
1482
1483                      if Unit.Name = The_Original_Name
1484                        or else
1485                          Current_Name = File_Name_Type (The_Original_Name)
1486                      then
1487                         if Current_Verbosity = High then
1488                            Write_Line ("   OK");
1489                         end if;
1490
1491                         if Full_Path then
1492                            return Get_Name_String
1493                              (Unit.File_Names (Body_Part).Path);
1494
1495                         else
1496                            return Get_Name_String (Current_Name);
1497                         end if;
1498
1499                         --  If it has the name of the extended body name,
1500                         --  return the extended body name
1501
1502                      elsif Current_Name = File_Name_Type (The_Body_Name) then
1503                         if Current_Verbosity = High then
1504                            Write_Line ("   OK");
1505                         end if;
1506
1507                         if Full_Path then
1508                            return Get_Name_String
1509                              (Unit.File_Names (Body_Part).Path);
1510
1511                         else
1512                            return Extended_Body_Name;
1513                         end if;
1514
1515                      else
1516                         if Current_Verbosity = High then
1517                            Write_Line ("   not good");
1518                         end if;
1519                      end if;
1520                   end if;
1521                end;
1522             end if;
1523
1524             --  Check for spec
1525
1526             if not Main_Project_Only
1527               or else Unit.File_Names (Specification).Project = The_Project
1528             then
1529                declare
1530                   Current_Name : constant File_Name_Type :=
1531                                    Unit.File_Names (Specification).Name;
1532
1533                begin
1534                   --  Case of spec present
1535
1536                   if Current_Name /= No_File then
1537                      if Current_Verbosity = High then
1538                         Write_Str  ("   Comparing with """);
1539                         Write_Str  (Get_Name_String (Current_Name));
1540                         Write_Char ('"');
1541                         Write_Eol;
1542                      end if;
1543
1544                      --  If name same as original name, return original name
1545
1546                      if Unit.Name = The_Original_Name
1547                        or else
1548                          Current_Name = File_Name_Type (The_Original_Name)
1549                      then
1550                         if Current_Verbosity = High then
1551                            Write_Line ("   OK");
1552                         end if;
1553
1554                         if Full_Path then
1555                            return Get_Name_String
1556                              (Unit.File_Names (Specification).Path);
1557                         else
1558                            return Get_Name_String (Current_Name);
1559                         end if;
1560
1561                         --  If it has the same name as the extended spec name,
1562                         --  return the extended spec name.
1563
1564                      elsif Current_Name = File_Name_Type (The_Spec_Name) then
1565                         if Current_Verbosity = High then
1566                            Write_Line ("   OK");
1567                         end if;
1568
1569                         if Full_Path then
1570                            return Get_Name_String
1571                              (Unit.File_Names (Specification).Path);
1572                         else
1573                            return Extended_Spec_Name;
1574                         end if;
1575
1576                      else
1577                         if Current_Verbosity = High then
1578                            Write_Line ("   not good");
1579                         end if;
1580                      end if;
1581                   end if;
1582                end;
1583             end if;
1584          end loop;
1585
1586          --  If we are not in an extending project, give up
1587
1588          exit when (not Main_Project_Only) or else Data.Extends = No_Project;
1589
1590          --  Otherwise, look in the project we are extending
1591
1592          The_Project := Data.Extends;
1593          Data := In_Tree.Projects.Table (The_Project);
1594       end loop;
1595
1596       --  We don't know this file name, return an empty string
1597
1598       return "";
1599    end File_Name_Of_Library_Unit_Body;
1600
1601    -------------------------
1602    -- For_All_Object_Dirs --
1603    -------------------------
1604
1605    procedure For_All_Object_Dirs
1606      (Project : Project_Id;
1607       In_Tree : Project_Tree_Ref)
1608    is
1609       Seen : Project_List := Empty_Project_List;
1610
1611       procedure Add (Project : Project_Id);
1612       --  Process a project. Remember the processes visited to avoid processing
1613       --  a project twice. Recursively process an eventual extended project,
1614       --  and all imported projects.
1615
1616       ---------
1617       -- Add --
1618       ---------
1619
1620       procedure Add (Project : Project_Id) is
1621          Data : constant Project_Data :=
1622                   In_Tree.Projects.Table (Project);
1623          List : Project_List := Data.Imported_Projects;
1624
1625       begin
1626          --  If the list of visited project is empty, then
1627          --  for sure we never visited this project.
1628
1629          if Seen = Empty_Project_List then
1630             Project_List_Table.Increment_Last (In_Tree.Project_Lists);
1631             Seen := Project_List_Table.Last (In_Tree.Project_Lists);
1632             In_Tree.Project_Lists.Table (Seen) :=
1633               (Project => Project, Next => Empty_Project_List);
1634
1635          else
1636             --  Check if the project is in the list
1637
1638             declare
1639                Current : Project_List := Seen;
1640
1641             begin
1642                loop
1643                   --  If it is, then there is nothing else to do
1644
1645                   if In_Tree.Project_Lists.Table
1646                                            (Current).Project = Project
1647                   then
1648                      return;
1649                   end if;
1650
1651                   exit when
1652                     In_Tree.Project_Lists.Table (Current).Next =
1653                       Empty_Project_List;
1654                   Current :=
1655                     In_Tree.Project_Lists.Table (Current).Next;
1656                end loop;
1657
1658                --  This project has never been visited, add it
1659                --  to the list.
1660
1661                Project_List_Table.Increment_Last
1662                  (In_Tree.Project_Lists);
1663                In_Tree.Project_Lists.Table (Current).Next :=
1664                  Project_List_Table.Last (In_Tree.Project_Lists);
1665                In_Tree.Project_Lists.Table
1666                  (Project_List_Table.Last
1667                     (In_Tree.Project_Lists)) :=
1668                  (Project => Project, Next => Empty_Project_List);
1669             end;
1670          end if;
1671
1672          --  If there is an object directory, call Action with its name
1673
1674          if Data.Object_Directory /= No_Path then
1675             Get_Name_String (Data.Display_Object_Dir);
1676             Action (Name_Buffer (1 .. Name_Len));
1677          end if;
1678
1679          --  If we are extending a project, visit it
1680
1681          if Data.Extends /= No_Project then
1682             Add (Data.Extends);
1683          end if;
1684
1685          --  And visit all imported projects
1686
1687          while List /= Empty_Project_List loop
1688             Add (In_Tree.Project_Lists.Table (List).Project);
1689             List := In_Tree.Project_Lists.Table (List).Next;
1690          end loop;
1691       end Add;
1692
1693    --  Start of processing for For_All_Object_Dirs
1694
1695    begin
1696       --  Visit this project, and its imported projects, recursively
1697
1698       Add (Project);
1699    end For_All_Object_Dirs;
1700
1701    -------------------------
1702    -- For_All_Source_Dirs --
1703    -------------------------
1704
1705    procedure For_All_Source_Dirs
1706      (Project : Project_Id;
1707       In_Tree : Project_Tree_Ref)
1708    is
1709       Seen : Project_List := Empty_Project_List;
1710
1711       procedure Add (Project : Project_Id);
1712       --  Process a project. Remember the processes visited to avoid processing
1713       --  a project twice. Recursively process an eventual extended project,
1714       --  and all imported projects.
1715
1716       ---------
1717       -- Add --
1718       ---------
1719
1720       procedure Add (Project : Project_Id) is
1721          Data : constant Project_Data :=
1722                   In_Tree.Projects.Table (Project);
1723          List : Project_List := Data.Imported_Projects;
1724
1725       begin
1726          --  If the list of visited project is empty, then for sure we never
1727          --  visited this project.
1728
1729          if Seen = Empty_Project_List then
1730             Project_List_Table.Increment_Last
1731               (In_Tree.Project_Lists);
1732             Seen := Project_List_Table.Last
1733                                          (In_Tree.Project_Lists);
1734             In_Tree.Project_Lists.Table (Seen) :=
1735               (Project => Project, Next => Empty_Project_List);
1736
1737          else
1738             --  Check if the project is in the list
1739
1740             declare
1741                Current : Project_List := Seen;
1742
1743             begin
1744                loop
1745                   --  If it is, then there is nothing else to do
1746
1747                   if In_Tree.Project_Lists.Table
1748                                            (Current).Project = Project
1749                   then
1750                      return;
1751                   end if;
1752
1753                   exit when
1754                     In_Tree.Project_Lists.Table (Current).Next =
1755                       Empty_Project_List;
1756                   Current :=
1757                     In_Tree.Project_Lists.Table (Current).Next;
1758                end loop;
1759
1760                --  This project has never been visited, add it to the list
1761
1762                Project_List_Table.Increment_Last
1763                  (In_Tree.Project_Lists);
1764                In_Tree.Project_Lists.Table (Current).Next :=
1765                  Project_List_Table.Last (In_Tree.Project_Lists);
1766                In_Tree.Project_Lists.Table
1767                  (Project_List_Table.Last
1768                     (In_Tree.Project_Lists)) :=
1769                  (Project => Project, Next => Empty_Project_List);
1770             end;
1771          end if;
1772
1773          declare
1774             Current    : String_List_Id := Data.Source_Dirs;
1775             The_String : String_Element;
1776
1777          begin
1778             --  If there are Ada sources, call action with the name of every
1779             --  source directory.
1780
1781             if
1782               In_Tree.Projects.Table (Project).Ada_Sources /= Nil_String
1783             then
1784                while Current /= Nil_String loop
1785                   The_String :=
1786                     In_Tree.String_Elements.Table (Current);
1787                   Action (Get_Name_String (The_String.Display_Value));
1788                   Current := The_String.Next;
1789                end loop;
1790             end if;
1791          end;
1792
1793          --  If we are extending a project, visit it
1794
1795          if Data.Extends /= No_Project then
1796             Add (Data.Extends);
1797          end if;
1798
1799          --  And visit all imported projects
1800
1801          while List /= Empty_Project_List loop
1802             Add (In_Tree.Project_Lists.Table (List).Project);
1803             List := In_Tree.Project_Lists.Table (List).Next;
1804          end loop;
1805       end Add;
1806
1807    --  Start of processing for For_All_Source_Dirs
1808
1809    begin
1810       --  Visit this project, and its imported projects recursively
1811
1812       Add (Project);
1813    end For_All_Source_Dirs;
1814
1815    -------------------
1816    -- Get_Reference --
1817    -------------------
1818
1819    procedure Get_Reference
1820      (Source_File_Name : String;
1821       In_Tree          : Project_Tree_Ref;
1822       Project          : out Project_Id;
1823       Path             : out Path_Name_Type)
1824    is
1825    begin
1826       --  Body below could use some comments ???
1827
1828       if Current_Verbosity > Default then
1829          Write_Str ("Getting Reference_Of (""");
1830          Write_Str (Source_File_Name);
1831          Write_Str (""") ... ");
1832       end if;
1833
1834       declare
1835          Original_Name : String := Source_File_Name;
1836          Unit          : Unit_Data;
1837
1838       begin
1839          Canonical_Case_File_Name (Original_Name);
1840
1841          for Id in Unit_Table.First ..
1842                    Unit_Table.Last (In_Tree.Units)
1843          loop
1844             Unit := In_Tree.Units.Table (Id);
1845
1846             if (Unit.File_Names (Specification).Name /= No_File
1847                  and then
1848                    Namet.Get_Name_String
1849                      (Unit.File_Names (Specification).Name) = Original_Name)
1850               or else (Unit.File_Names (Specification).Path /= No_Path
1851                          and then
1852                            Namet.Get_Name_String
1853                            (Unit.File_Names (Specification).Path) =
1854                                                               Original_Name)
1855             then
1856                Project := Ultimate_Extension_Of
1857                            (Project => Unit.File_Names (Specification).Project,
1858                             In_Tree => In_Tree);
1859                Path := Unit.File_Names (Specification).Display_Path;
1860
1861                if Current_Verbosity > Default then
1862                   Write_Str ("Done: Specification.");
1863                   Write_Eol;
1864                end if;
1865
1866                return;
1867
1868             elsif (Unit.File_Names (Body_Part).Name /= No_File
1869                     and then
1870                       Namet.Get_Name_String
1871                         (Unit.File_Names (Body_Part).Name) = Original_Name)
1872               or else (Unit.File_Names (Body_Part).Path /= No_Path
1873                          and then Namet.Get_Name_String
1874                                     (Unit.File_Names (Body_Part).Path) =
1875                                                              Original_Name)
1876             then
1877                Project := Ultimate_Extension_Of
1878                             (Project => Unit.File_Names (Body_Part).Project,
1879                              In_Tree => In_Tree);
1880                Path := Unit.File_Names (Body_Part).Display_Path;
1881
1882                if Current_Verbosity > Default then
1883                   Write_Str ("Done: Body.");
1884                   Write_Eol;
1885                end if;
1886
1887                return;
1888             end if;
1889          end loop;
1890       end;
1891
1892       Project := No_Project;
1893       Path    := No_Path;
1894
1895       if Current_Verbosity > Default then
1896          Write_Str ("Cannot be found.");
1897          Write_Eol;
1898       end if;
1899    end Get_Reference;
1900
1901    ----------------
1902    -- Initialize --
1903    ----------------
1904
1905    procedure Initialize is
1906    begin
1907       Fill_Mapping_File := True;
1908    end Initialize;
1909
1910    ------------------------------------
1911    -- Path_Name_Of_Library_Unit_Body --
1912    ------------------------------------
1913
1914    --  Could use some comments in the body here ???
1915
1916    function Path_Name_Of_Library_Unit_Body
1917      (Name    : String;
1918       Project : Project_Id;
1919       In_Tree : Project_Tree_Ref) return String
1920    is
1921       Data          : constant Project_Data :=
1922                         In_Tree.Projects.Table (Project);
1923       Original_Name : String := Name;
1924
1925       Extended_Spec_Name : String :=
1926                              Name &
1927                              Spec_Suffix_Of (In_Tree, "ada", Data.Naming);
1928       Extended_Body_Name : String :=
1929                              Name &
1930                              Body_Suffix_Of (In_Tree, "ada", Data.Naming);
1931
1932       First   : Unit_Index := Unit_Table.First;
1933       Current : Unit_Index;
1934       Unit    : Unit_Data;
1935
1936    begin
1937       Canonical_Case_File_Name (Original_Name);
1938       Canonical_Case_File_Name (Extended_Spec_Name);
1939       Canonical_Case_File_Name (Extended_Body_Name);
1940
1941       if Current_Verbosity = High then
1942          Write_Str  ("Looking for path name of """);
1943          Write_Str  (Name);
1944          Write_Char ('"');
1945          Write_Eol;
1946          Write_Str  ("   Extended Spec Name = """);
1947          Write_Str  (Extended_Spec_Name);
1948          Write_Char ('"');
1949          Write_Eol;
1950          Write_Str  ("   Extended Body Name = """);
1951          Write_Str  (Extended_Body_Name);
1952          Write_Char ('"');
1953          Write_Eol;
1954       end if;
1955
1956       while First <= Unit_Table.Last (In_Tree.Units)
1957         and then In_Tree.Units.Table
1958                    (First).File_Names (Body_Part).Project /= Project
1959       loop
1960          First := First + 1;
1961       end loop;
1962
1963       Current := First;
1964       while Current <= Unit_Table.Last (In_Tree.Units) loop
1965          Unit := In_Tree.Units.Table (Current);
1966
1967          if Unit.File_Names (Body_Part).Project = Project
1968            and then Unit.File_Names (Body_Part).Name /= No_File
1969          then
1970             declare
1971                Current_Name : constant String :=
1972                  Namet.Get_Name_String (Unit.File_Names (Body_Part).Name);
1973             begin
1974                if Current_Verbosity = High then
1975                   Write_Str  ("   Comparing with """);
1976                   Write_Str  (Current_Name);
1977                   Write_Char ('"');
1978                   Write_Eol;
1979                end if;
1980
1981                if Current_Name = Original_Name then
1982                   if Current_Verbosity = High then
1983                      Write_Line ("   OK");
1984                   end if;
1985
1986                   return Body_Path_Name_Of (Current, In_Tree);
1987
1988                elsif Current_Name = Extended_Body_Name then
1989                   if Current_Verbosity = High then
1990                      Write_Line ("   OK");
1991                   end if;
1992
1993                   return Body_Path_Name_Of (Current, In_Tree);
1994
1995                else
1996                   if Current_Verbosity = High then
1997                      Write_Line ("   not good");
1998                   end if;
1999                end if;
2000             end;
2001
2002          elsif Unit.File_Names (Specification).Name /= No_File then
2003             declare
2004                Current_Name : constant String :=
2005                                 Namet.Get_Name_String
2006                                   (Unit.File_Names (Specification).Name);
2007
2008             begin
2009                if Current_Verbosity = High then
2010                   Write_Str  ("   Comparing with """);
2011                   Write_Str  (Current_Name);
2012                   Write_Char ('"');
2013                   Write_Eol;
2014                end if;
2015
2016                if Current_Name = Original_Name then
2017                   if Current_Verbosity = High then
2018                      Write_Line ("   OK");
2019                   end if;
2020
2021                   return Spec_Path_Name_Of (Current, In_Tree);
2022
2023                elsif Current_Name = Extended_Spec_Name then
2024                   if Current_Verbosity = High then
2025                      Write_Line ("   OK");
2026                   end if;
2027
2028                   return Spec_Path_Name_Of (Current, In_Tree);
2029
2030                else
2031                   if Current_Verbosity = High then
2032                      Write_Line ("   not good");
2033                   end if;
2034                end if;
2035             end;
2036          end if;
2037          Current := Current + 1;
2038       end loop;
2039
2040       return "";
2041    end Path_Name_Of_Library_Unit_Body;
2042
2043    -------------------
2044    -- Print_Sources --
2045    -------------------
2046
2047    --  Could use some comments in this body ???
2048
2049    procedure Print_Sources (In_Tree : Project_Tree_Ref) is
2050       Unit : Unit_Data;
2051
2052    begin
2053       Write_Line ("List of Sources:");
2054
2055       for Id in Unit_Table.First ..
2056                 Unit_Table.Last (In_Tree.Units)
2057       loop
2058          Unit := In_Tree.Units.Table (Id);
2059          Write_Str  ("   ");
2060          Write_Line (Namet.Get_Name_String (Unit.Name));
2061
2062          if Unit.File_Names (Specification).Name /= No_File then
2063             if Unit.File_Names (Specification).Project = No_Project then
2064                Write_Line ("   No project");
2065
2066             else
2067                Write_Str  ("   Project: ");
2068                Get_Name_String
2069                  (In_Tree.Projects.Table
2070                    (Unit.File_Names (Specification).Project).Path_Name);
2071                Write_Line (Name_Buffer (1 .. Name_Len));
2072             end if;
2073
2074             Write_Str  ("      spec: ");
2075             Write_Line
2076               (Namet.Get_Name_String
2077                (Unit.File_Names (Specification).Name));
2078          end if;
2079
2080          if Unit.File_Names (Body_Part).Name /= No_File then
2081             if Unit.File_Names (Body_Part).Project = No_Project then
2082                Write_Line ("   No project");
2083
2084             else
2085                Write_Str  ("   Project: ");
2086                Get_Name_String
2087                  (In_Tree.Projects.Table
2088                    (Unit.File_Names (Body_Part).Project).Path_Name);
2089                Write_Line (Name_Buffer (1 .. Name_Len));
2090             end if;
2091
2092             Write_Str  ("      body: ");
2093             Write_Line
2094               (Namet.Get_Name_String
2095                (Unit.File_Names (Body_Part).Name));
2096          end if;
2097       end loop;
2098
2099       Write_Line ("end of List of Sources.");
2100    end Print_Sources;
2101
2102    ----------------
2103    -- Project_Of --
2104    ----------------
2105
2106    function Project_Of
2107      (Name         : String;
2108       Main_Project : Project_Id;
2109       In_Tree      : Project_Tree_Ref) return Project_Id
2110    is
2111       Result : Project_Id := No_Project;
2112
2113       Original_Name : String := Name;
2114
2115       Data   : constant Project_Data :=
2116         In_Tree.Projects.Table (Main_Project);
2117
2118       Extended_Spec_Name : String :=
2119                              Name &
2120                              Spec_Suffix_Of (In_Tree, "ada", Data.Naming);
2121       Extended_Body_Name : String :=
2122                              Name &
2123                              Body_Suffix_Of (In_Tree, "ada", Data.Naming);
2124
2125       Unit : Unit_Data;
2126
2127       Current_Name      : File_Name_Type;
2128       The_Original_Name : File_Name_Type;
2129       The_Spec_Name     : File_Name_Type;
2130       The_Body_Name     : File_Name_Type;
2131
2132    begin
2133       Canonical_Case_File_Name (Original_Name);
2134       Name_Len := Original_Name'Length;
2135       Name_Buffer (1 .. Name_Len) := Original_Name;
2136       The_Original_Name := Name_Find;
2137
2138       Canonical_Case_File_Name (Extended_Spec_Name);
2139       Name_Len := Extended_Spec_Name'Length;
2140       Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
2141       The_Spec_Name := Name_Find;
2142
2143       Canonical_Case_File_Name (Extended_Body_Name);
2144       Name_Len := Extended_Body_Name'Length;
2145       Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
2146       The_Body_Name := Name_Find;
2147
2148       for Current in reverse Unit_Table.First ..
2149                              Unit_Table.Last (In_Tree.Units)
2150       loop
2151          Unit := In_Tree.Units.Table (Current);
2152
2153          --  Check for body
2154
2155          Current_Name := Unit.File_Names (Body_Part).Name;
2156
2157          --  Case of a body present
2158
2159          if Current_Name /= No_File then
2160
2161             --  If it has the name of the original name or the body name,
2162             --  we have found the project.
2163
2164             if Unit.Name = Name_Id (The_Original_Name)
2165               or else Current_Name = The_Original_Name
2166               or else Current_Name = The_Body_Name
2167             then
2168                Result := Unit.File_Names (Body_Part).Project;
2169                exit;
2170             end if;
2171          end if;
2172
2173          --  Check for spec
2174
2175          Current_Name := Unit.File_Names (Specification).Name;
2176
2177          if Current_Name /= No_File then
2178
2179             --  If name same as the original name, or the spec name, we have
2180             --  found the project.
2181
2182             if Unit.Name = Name_Id (The_Original_Name)
2183               or else Current_Name = The_Original_Name
2184               or else Current_Name = The_Spec_Name
2185             then
2186                Result := Unit.File_Names (Specification).Project;
2187                exit;
2188             end if;
2189          end if;
2190       end loop;
2191
2192       --  Get the ultimate extending project
2193
2194       if Result /= No_Project then
2195          while In_Tree.Projects.Table (Result).Extended_By /=
2196            No_Project
2197          loop
2198             Result := In_Tree.Projects.Table (Result).Extended_By;
2199          end loop;
2200       end if;
2201
2202       return Result;
2203    end Project_Of;
2204
2205    -------------------
2206    -- Set_Ada_Paths --
2207    -------------------
2208
2209    procedure Set_Ada_Paths
2210      (Project             : Project_Id;
2211       In_Tree             : Project_Tree_Ref;
2212       Including_Libraries : Boolean)
2213    is
2214       Source_FD : File_Descriptor := Invalid_FD;
2215       Object_FD : File_Descriptor := Invalid_FD;
2216
2217       Process_Source_Dirs : Boolean := False;
2218       Process_Object_Dirs : Boolean := False;
2219
2220       Status : Boolean;
2221       --  For calls to Close
2222
2223       Len : Natural;
2224
2225       procedure Add (Proj : Project_Id);
2226       --  Add all the source/object directories of a project to the path only
2227       --  if this project has not been visited. Calls an internal procedure
2228       --  recursively for projects being extended, and imported projects.
2229
2230       ---------
2231       -- Add --
2232       ---------
2233
2234       procedure Add (Proj : Project_Id) is
2235
2236          procedure Recursive_Add (Project : Project_Id);
2237          --  Recursive procedure to add the source/object paths of extended/
2238          --  imported projects.
2239
2240          -------------------
2241          -- Recursive_Add --
2242          -------------------
2243
2244          procedure Recursive_Add (Project : Project_Id) is
2245          begin
2246             --  If Seen is False, then the project has not yet been visited
2247
2248             if not In_Tree.Projects.Table (Project).Seen then
2249                In_Tree.Projects.Table (Project).Seen := True;
2250
2251                declare
2252                   Data : constant Project_Data :=
2253                     In_Tree.Projects.Table (Project);
2254                   List : Project_List := Data.Imported_Projects;
2255
2256                begin
2257                   if Process_Source_Dirs then
2258
2259                      --  Add to path all source directories of this project if
2260                      --  there are Ada sources.
2261
2262                      if In_Tree.Projects.Table (Project).Ada_Sources /=
2263                         Nil_String
2264                      then
2265                         Add_To_Source_Path (Data.Source_Dirs, In_Tree);
2266                      end if;
2267                   end if;
2268
2269                   if Process_Object_Dirs then
2270
2271                      --  Add to path the object directory of this project
2272                      --  except if we don't include library project and this
2273                      --  is a library project.
2274
2275                      if (Data.Library and then Including_Libraries)
2276                        or else
2277                          (Data.Object_Directory /= No_Path
2278                           and then
2279                             (not Including_Libraries or else not Data.Library))
2280                      then
2281                         --  For a library project, add the library ALI
2282                         --  directory if there is no object directory or
2283                         --  if the library ALI directory contains ALI files;
2284                         --  otherwise add the object directory.
2285
2286                         if Data.Library then
2287                            if Data.Object_Directory = No_Path
2288                              or else Contains_ALI_Files (Data.Library_ALI_Dir)
2289                            then
2290                               Add_To_Object_Path
2291                                 (Data.Library_ALI_Dir, In_Tree);
2292                            else
2293                               Add_To_Object_Path
2294                                 (Data.Object_Directory, In_Tree);
2295                            end if;
2296
2297                         --  For a non-library project, add the object
2298                         --  directory, if it is not a virtual project, and if
2299                         --  there are Ada sources or if the project is an
2300                         --  extending project. if There Are No Ada sources,
2301                         --  adding the object directory could disrupt the order
2302                         --  of the object dirs in the path.
2303
2304                         elsif not Data.Virtual
2305                           and then There_Are_Ada_Sources (In_Tree, Project)
2306                         then
2307                            Add_To_Object_Path
2308                              (Data.Object_Directory, In_Tree);
2309                         end if;
2310                      end if;
2311                   end if;
2312
2313                   --  Call Add to the project being extended, if any
2314
2315                   if Data.Extends /= No_Project then
2316                      Recursive_Add (Data.Extends);
2317                   end if;
2318
2319                   --  Call Add for each imported project, if any
2320
2321                   while List /= Empty_Project_List loop
2322                      Recursive_Add
2323                        (In_Tree.Project_Lists.Table
2324                           (List).Project);
2325                      List :=
2326                        In_Tree.Project_Lists.Table (List).Next;
2327                   end loop;
2328                end;
2329             end if;
2330          end Recursive_Add;
2331
2332       begin
2333          Source_Path_Table.Set_Last (In_Tree.Private_Part.Source_Paths, 0);
2334          Object_Path_Table.Set_Last (In_Tree.Private_Part.Object_Paths, 0);
2335
2336          for Index in Project_Table.First ..
2337                       Project_Table.Last (In_Tree.Projects)
2338          loop
2339             In_Tree.Projects.Table (Index).Seen := False;
2340          end loop;
2341
2342          Recursive_Add (Proj);
2343       end Add;
2344
2345    --  Start of processing for Set_Ada_Paths
2346
2347    begin
2348       --  If it is the first time we call this procedure for
2349       --  this project, compute the source path and/or the object path.
2350
2351       if In_Tree.Projects.Table (Project).Include_Path_File = No_Path then
2352          Process_Source_Dirs := True;
2353          Create_New_Path_File
2354            (In_Tree, Source_FD,
2355             In_Tree.Projects.Table (Project).Include_Path_File);
2356       end if;
2357
2358       --  For the object path, we make a distinction depending on
2359       --  Including_Libraries.
2360
2361       if Including_Libraries then
2362          if In_Tree.Projects.Table
2363            (Project).Objects_Path_File_With_Libs = No_Path
2364          then
2365             Process_Object_Dirs := True;
2366             Create_New_Path_File
2367               (In_Tree, Object_FD, In_Tree.Projects.Table (Project).
2368                                            Objects_Path_File_With_Libs);
2369          end if;
2370
2371       else
2372          if In_Tree.Projects.Table
2373               (Project).Objects_Path_File_Without_Libs = No_Path
2374          then
2375             Process_Object_Dirs := True;
2376             Create_New_Path_File
2377               (In_Tree, Object_FD, In_Tree.Projects.Table (Project).
2378                                            Objects_Path_File_Without_Libs);
2379          end if;
2380       end if;
2381
2382       --  If there is something to do, set Seen to False for all projects,
2383       --  then call the recursive procedure Add for Project.
2384
2385       if Process_Source_Dirs or Process_Object_Dirs then
2386          Add (Project);
2387       end if;
2388
2389       --  Write and close any file that has been created
2390
2391       if Source_FD /= Invalid_FD then
2392          for Index in Source_Path_Table.First ..
2393                       Source_Path_Table.Last
2394                         (In_Tree.Private_Part.Source_Paths)
2395          loop
2396             Get_Name_String (In_Tree.Private_Part.Source_Paths.Table (Index));
2397             Name_Len := Name_Len + 1;
2398             Name_Buffer (Name_Len) := ASCII.LF;
2399             Len := Write (Source_FD, Name_Buffer (1)'Address, Name_Len);
2400
2401             if Len /= Name_Len then
2402                Prj.Com.Fail ("disk full");
2403             end if;
2404          end loop;
2405
2406          Close (Source_FD, Status);
2407
2408          if not Status then
2409             Prj.Com.Fail ("disk full");
2410          end if;
2411       end if;
2412
2413       if Object_FD /= Invalid_FD then
2414          for Index in Object_Path_Table.First ..
2415                       Object_Path_Table.Last
2416                         (In_Tree.Private_Part.Object_Paths)
2417          loop
2418             Get_Name_String (In_Tree.Private_Part.Object_Paths.Table (Index));
2419             Name_Len := Name_Len + 1;
2420             Name_Buffer (Name_Len) := ASCII.LF;
2421             Len := Write (Object_FD, Name_Buffer (1)'Address, Name_Len);
2422
2423             if Len /= Name_Len then
2424                Prj.Com.Fail ("disk full");
2425             end if;
2426          end loop;
2427
2428          Close (Object_FD, Status);
2429
2430          if not Status then
2431             Prj.Com.Fail ("disk full");
2432          end if;
2433       end if;
2434
2435       --  Set the env vars, if they need to be changed, and set the
2436       --  corresponding flags.
2437
2438       if Current_Source_Path_File /=
2439            In_Tree.Projects.Table (Project).Include_Path_File
2440       then
2441          Current_Source_Path_File :=
2442            In_Tree.Projects.Table (Project).Include_Path_File;
2443          Set_Path_File_Var
2444            (Project_Include_Path_File,
2445             Get_Name_String (Current_Source_Path_File));
2446          Ada_Prj_Include_File_Set := True;
2447       end if;
2448
2449       if Including_Libraries then
2450          if Current_Object_Path_File
2451            /= In_Tree.Projects.Table
2452                 (Project).Objects_Path_File_With_Libs
2453          then
2454             Current_Object_Path_File :=
2455               In_Tree.Projects.Table
2456                 (Project).Objects_Path_File_With_Libs;
2457             Set_Path_File_Var
2458               (Project_Objects_Path_File,
2459                Get_Name_String (Current_Object_Path_File));
2460             Ada_Prj_Objects_File_Set := True;
2461          end if;
2462
2463       else
2464          if Current_Object_Path_File /=
2465            In_Tree.Projects.Table
2466              (Project).Objects_Path_File_Without_Libs
2467          then
2468             Current_Object_Path_File :=
2469               In_Tree.Projects.Table
2470                 (Project).Objects_Path_File_Without_Libs;
2471             Set_Path_File_Var
2472               (Project_Objects_Path_File,
2473                Get_Name_String (Current_Object_Path_File));
2474             Ada_Prj_Objects_File_Set := True;
2475          end if;
2476       end if;
2477    end Set_Ada_Paths;
2478
2479    ---------------------------------------------
2480    -- Set_Mapping_File_Initial_State_To_Empty --
2481    ---------------------------------------------
2482
2483    procedure Set_Mapping_File_Initial_State_To_Empty is
2484    begin
2485       Fill_Mapping_File := False;
2486    end Set_Mapping_File_Initial_State_To_Empty;
2487
2488    -----------------------
2489    -- Set_Path_File_Var --
2490    -----------------------
2491
2492    procedure Set_Path_File_Var (Name : String; Value : String) is
2493       Host_Spec : String_Access := To_Host_File_Spec (Value);
2494
2495    begin
2496       if Host_Spec = null then
2497          Prj.Com.Fail
2498            ("could not convert file name """, Value, """ to host spec");
2499       else
2500          Setenv (Name, Host_Spec.all);
2501          Free (Host_Spec);
2502       end if;
2503    end Set_Path_File_Var;
2504
2505    -----------------------
2506    -- Spec_Path_Name_Of --
2507    -----------------------
2508
2509    function Spec_Path_Name_Of
2510      (Unit : Unit_Index; In_Tree : Project_Tree_Ref) return String
2511    is
2512       Data : Unit_Data := In_Tree.Units.Table (Unit);
2513
2514    begin
2515       if Data.File_Names (Specification).Path = No_Path then
2516          declare
2517             Current_Source : String_List_Id :=
2518               In_Tree.Projects.Table
2519                 (Data.File_Names (Specification).Project).Ada_Sources;
2520             Path : GNAT.OS_Lib.String_Access;
2521
2522          begin
2523             Data.File_Names (Specification).Path :=
2524               Path_Name_Type (Data.File_Names (Specification).Name);
2525
2526             while Current_Source /= Nil_String loop
2527                Path := Locate_Regular_File
2528                  (Namet.Get_Name_String
2529                   (Data.File_Names (Specification).Name),
2530                   Namet.Get_Name_String
2531                     (In_Tree.String_Elements.Table
2532                        (Current_Source).Value));
2533
2534                if Path /= null then
2535                   Name_Len := Path'Length;
2536                   Name_Buffer (1 .. Name_Len) := Path.all;
2537                   Data.File_Names (Specification).Path := Name_Enter;
2538                   exit;
2539                else
2540                   Current_Source :=
2541                     In_Tree.String_Elements.Table
2542                       (Current_Source).Next;
2543                end if;
2544             end loop;
2545
2546             In_Tree.Units.Table (Unit) := Data;
2547          end;
2548       end if;
2549
2550       return Namet.Get_Name_String (Data.File_Names (Specification).Path);
2551    end Spec_Path_Name_Of;
2552
2553    ---------------------------
2554    -- Ultimate_Extension_Of --
2555    ---------------------------
2556
2557    function Ultimate_Extension_Of
2558      (Project : Project_Id;
2559       In_Tree : Project_Tree_Ref) return Project_Id
2560    is
2561       Result : Project_Id := Project;
2562
2563    begin
2564       while In_Tree.Projects.Table (Result).Extended_By /=
2565         No_Project
2566       loop
2567          Result := In_Tree.Projects.Table (Result).Extended_By;
2568       end loop;
2569
2570       return Result;
2571    end Ultimate_Extension_Of;
2572
2573 end Prj.Env;