gcc/ada/prj-env.adb

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