OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [prj-env.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                              P R J . E N V                               --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 2001-2012, Free Software Foundation, Inc.         --
10
--                                                                          --
11
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12
-- terms of the  GNU General Public License as published  by the Free Soft- --
13
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
17
-- for  more details.  You should have  received  a copy of the GNU General --
18
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
19
-- http://www.gnu.org/licenses for a complete copy of the license.          --
20
--                                                                          --
21
-- GNAT was originally developed  by the GNAT team at  New York University. --
22
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
23
--                                                                          --
24
------------------------------------------------------------------------------
25
 
26
with Fmap;
27
with Hostparm;
28
with Makeutl;  use Makeutl;
29
with Opt;
30
with Osint;    use Osint;
31
with Output;   use Output;
32
with Prj.Com;  use Prj.Com;
33
with Sdefault;
34
with Tempdir;
35
 
36
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
37
 
38
package body Prj.Env is
39
 
40
   Buffer_Initial : constant := 1_000;
41
   --  Initial size of Buffer
42
 
43
   Uninitialized_Prefix : constant String := '#' & Path_Separator;
44
   --  Prefix to indicate that the project path has not been initialized yet.
45
   --  Must be two characters long
46
 
47
   No_Project_Default_Dir : constant String := "-";
48
   --  Indicator in the project path to indicate that the default search
49
   --  directories should not be added to the path
50
 
51
   -----------------------
52
   -- Local Subprograms --
53
   -----------------------
54
 
55
   package Source_Path_Table is new GNAT.Dynamic_Tables
56
     (Table_Component_Type => Name_Id,
57
      Table_Index_Type     => Natural,
58
      Table_Low_Bound      => 1,
59
      Table_Initial        => 50,
60
      Table_Increment      => 100);
61
   --  A table to store the source dirs before creating the source path file
62
 
63
   package Object_Path_Table is new GNAT.Dynamic_Tables
64
     (Table_Component_Type => Path_Name_Type,
65
      Table_Index_Type     => Natural,
66
      Table_Low_Bound      => 1,
67
      Table_Initial        => 50,
68
      Table_Increment      => 100);
69
   --  A table to store the object dirs, before creating the object path file
70
 
71
   procedure Add_To_Buffer
72
     (S           : String;
73
      Buffer      : in out String_Access;
74
      Buffer_Last : in out Natural);
75
   --  Add a string to Buffer, extending Buffer if needed
76
 
77
   procedure Add_To_Path
78
     (Source_Dirs : String_List_Id;
79
      Shared      : Shared_Project_Tree_Data_Access;
80
      Buffer      : in out String_Access;
81
      Buffer_Last : in out Natural);
82
   --  Add to Ada_Path_Buffer all the source directories in string list
83
   --  Source_Dirs, if any.
84
 
85
   procedure Add_To_Path
86
     (Dir         : String;
87
      Buffer      : in out String_Access;
88
      Buffer_Last : in out Natural);
89
   --  If Dir is not already in the global variable Ada_Path_Buffer, add it.
90
   --  If Buffer_Last /= 0, prepend a Path_Separator character to Path.
91
 
92
   procedure Add_To_Source_Path
93
     (Source_Dirs  : String_List_Id;
94
      Shared       : Shared_Project_Tree_Data_Access;
95
      Source_Paths : in out Source_Path_Table.Instance);
96
   --  Add to Ada_Path_B all the source directories in string list
97
   --  Source_Dirs, if any. Increment Ada_Path_Length.
98
 
99
   procedure Add_To_Object_Path
100
     (Object_Dir   : Path_Name_Type;
101
      Object_Paths : in out Object_Path_Table.Instance);
102
   --  Add Object_Dir to object path table. Make sure it is not duplicate
103
   --  and it is the last one in the current table.
104
 
105
   ----------------------
106
   -- Ada_Include_Path --
107
   ----------------------
108
 
109
   function Ada_Include_Path
110
     (Project   : Project_Id;
111
      In_Tree   : Project_Tree_Ref;
112
      Recursive : Boolean := False) return String
113
   is
114
      Buffer      : String_Access;
115
      Buffer_Last : Natural := 0;
116
 
117
      procedure Add
118
        (Project : Project_Id;
119
         In_Tree : Project_Tree_Ref;
120
         Dummy   : in out Boolean);
121
      --  Add source dirs of Project to the path
122
 
123
      ---------
124
      -- Add --
125
      ---------
126
 
127
      procedure Add
128
        (Project : Project_Id;
129
         In_Tree : Project_Tree_Ref;
130
         Dummy   : in out Boolean)
131
      is
132
         pragma Unreferenced (Dummy);
133
      begin
134
         Add_To_Path
135
           (Project.Source_Dirs, In_Tree.Shared, Buffer, Buffer_Last);
136
      end Add;
137
 
138
      procedure For_All_Projects is
139
        new For_Every_Project_Imported (Boolean, Add);
140
 
141
      Dummy : Boolean := False;
142
 
143
   --  Start of processing for Ada_Include_Path
144
 
145
   begin
146
      if Recursive then
147
 
148
         --  If it is the first time we call this function for
149
         --  this project, compute the source path
150
 
151
         if Project.Ada_Include_Path = null then
152
            Buffer := new String (1 .. 4096);
153
            For_All_Projects
154
              (Project, In_Tree, Dummy, Include_Aggregated => True);
155
            Project.Ada_Include_Path := new String'(Buffer (1 .. Buffer_Last));
156
            Free (Buffer);
157
         end if;
158
 
159
         return Project.Ada_Include_Path.all;
160
 
161
      else
162
         Buffer := new String (1 .. 4096);
163
         Add_To_Path
164
           (Project.Source_Dirs, In_Tree.Shared, Buffer, Buffer_Last);
165
 
166
         declare
167
            Result : constant String := Buffer (1 .. Buffer_Last);
168
         begin
169
            Free (Buffer);
170
            return Result;
171
         end;
172
      end if;
173
   end Ada_Include_Path;
174
 
175
   ----------------------
176
   -- Ada_Objects_Path --
177
   ----------------------
178
 
179
   function Ada_Objects_Path
180
     (Project             : Project_Id;
181
      In_Tree             : Project_Tree_Ref;
182
      Including_Libraries : Boolean := True) return String_Access
183
   is
184
      Buffer      : String_Access;
185
      Buffer_Last : Natural := 0;
186
 
187
      procedure Add
188
        (Project : Project_Id;
189
         In_Tree : Project_Tree_Ref;
190
         Dummy   : in out Boolean);
191
      --  Add all the object directories of a project to the path
192
 
193
      ---------
194
      -- Add --
195
      ---------
196
 
197
      procedure Add
198
        (Project : Project_Id;
199
         In_Tree : Project_Tree_Ref;
200
         Dummy   : in out Boolean)
201
      is
202
         pragma Unreferenced (Dummy, In_Tree);
203
 
204
         Path : constant Path_Name_Type :=
205
                  Get_Object_Directory
206
                    (Project,
207
                     Including_Libraries => Including_Libraries,
208
                     Only_If_Ada         => False);
209
      begin
210
         if Path /= No_Path then
211
            Add_To_Path (Get_Name_String (Path), Buffer, Buffer_Last);
212
         end if;
213
      end Add;
214
 
215
      procedure For_All_Projects is
216
        new For_Every_Project_Imported (Boolean, Add);
217
 
218
      Dummy : Boolean := False;
219
 
220
   --  Start of processing for Ada_Objects_Path
221
 
222
   begin
223
      --  If it is the first time we call this function for
224
      --  this project, compute the objects path
225
 
226
      if Project.Ada_Objects_Path = null then
227
         Buffer := new String (1 .. 4096);
228
         For_All_Projects (Project, In_Tree, Dummy);
229
 
230
         Project.Ada_Objects_Path := new String'(Buffer (1 .. Buffer_Last));
231
         Free (Buffer);
232
      end if;
233
 
234
      return Project.Ada_Objects_Path;
235
   end Ada_Objects_Path;
236
 
237
   -------------------
238
   -- Add_To_Buffer --
239
   -------------------
240
 
241
   procedure Add_To_Buffer
242
     (S           : String;
243
      Buffer      : in out String_Access;
244
      Buffer_Last : in out Natural)
245
   is
246
      Last : constant Natural := Buffer_Last + S'Length;
247
 
248
   begin
249
      while Last > Buffer'Last loop
250
         declare
251
            New_Buffer : constant String_Access :=
252
                           new String (1 .. 2 * Buffer'Last);
253
         begin
254
            New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last);
255
            Free (Buffer);
256
            Buffer := New_Buffer;
257
         end;
258
      end loop;
259
 
260
      Buffer (Buffer_Last + 1 .. Last) := S;
261
      Buffer_Last := Last;
262
   end Add_To_Buffer;
263
 
264
   ------------------------
265
   -- Add_To_Object_Path --
266
   ------------------------
267
 
268
   procedure Add_To_Object_Path
269
     (Object_Dir   : Path_Name_Type;
270
      Object_Paths : in out Object_Path_Table.Instance)
271
   is
272
   begin
273
      --  Check if the directory is already in the table
274
 
275
      for Index in
276
        Object_Path_Table.First .. Object_Path_Table.Last (Object_Paths)
277
      loop
278
 
279
         --  If it is, remove it, and add it as the last one
280
 
281
         if Object_Paths.Table (Index) = Object_Dir then
282
            for Index2 in
283
              Index + 1 .. Object_Path_Table.Last (Object_Paths)
284
            loop
285
               Object_Paths.Table (Index2 - 1) := Object_Paths.Table (Index2);
286
            end loop;
287
 
288
            Object_Paths.Table
289
              (Object_Path_Table.Last (Object_Paths)) := Object_Dir;
290
            return;
291
         end if;
292
      end loop;
293
 
294
      --  The directory is not already in the table, add it
295
 
296
      Object_Path_Table.Append (Object_Paths, Object_Dir);
297
   end Add_To_Object_Path;
298
 
299
   -----------------
300
   -- Add_To_Path --
301
   -----------------
302
 
303
   procedure Add_To_Path
304
     (Source_Dirs : String_List_Id;
305
      Shared      : Shared_Project_Tree_Data_Access;
306
      Buffer      : in out String_Access;
307
      Buffer_Last : in out Natural)
308
   is
309
      Current    : String_List_Id := Source_Dirs;
310
      Source_Dir : String_Element;
311
   begin
312
      while Current /= Nil_String loop
313
         Source_Dir := Shared.String_Elements.Table (Current);
314
         Add_To_Path (Get_Name_String (Source_Dir.Display_Value),
315
                      Buffer, Buffer_Last);
316
         Current := Source_Dir.Next;
317
      end loop;
318
   end Add_To_Path;
319
 
320
   procedure Add_To_Path
321
     (Dir         : String;
322
      Buffer      : in out String_Access;
323
      Buffer_Last : in out Natural)
324
   is
325
      Len        : Natural;
326
      New_Buffer : String_Access;
327
      Min_Len    : Natural;
328
 
329
      function Is_Present (Path : String; Dir : String) return Boolean;
330
      --  Return True if Dir is part of Path
331
 
332
      ----------------
333
      -- Is_Present --
334
      ----------------
335
 
336
      function Is_Present (Path : String; Dir : String) return Boolean is
337
         Last : constant Integer := Path'Last - Dir'Length + 1;
338
 
339
      begin
340
         for J in Path'First .. Last loop
341
 
342
            --  Note: the order of the conditions below is important, since
343
            --  it ensures a minimal number of string comparisons.
344
 
345
            if (J = Path'First
346
                or else Path (J - 1) = Path_Separator)
347
              and then
348
                (J + Dir'Length > Path'Last
349
                 or else Path (J + Dir'Length) = Path_Separator)
350
              and then Dir = Path (J .. J + Dir'Length - 1)
351
            then
352
               return True;
353
            end if;
354
         end loop;
355
 
356
         return False;
357
      end Is_Present;
358
 
359
   --  Start of processing for Add_To_Path
360
 
361
   begin
362
      if Is_Present (Buffer (1 .. Buffer_Last), Dir) then
363
 
364
         --  Dir is already in the path, nothing to do
365
 
366
         return;
367
      end if;
368
 
369
      Min_Len := Buffer_Last + Dir'Length;
370
 
371
      if Buffer_Last > 0 then
372
 
373
         --  Add 1 for the Path_Separator character
374
 
375
         Min_Len := Min_Len + 1;
376
      end if;
377
 
378
      --  If Ada_Path_Buffer is too small, increase it
379
 
380
      Len := Buffer'Last;
381
 
382
      if Len < Min_Len then
383
         loop
384
            Len := Len * 2;
385
            exit when Len >= Min_Len;
386
         end loop;
387
 
388
         New_Buffer := new String (1 .. Len);
389
         New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last);
390
         Free (Buffer);
391
         Buffer := New_Buffer;
392
      end if;
393
 
394
      if Buffer_Last > 0 then
395
         Buffer_Last := Buffer_Last + 1;
396
         Buffer (Buffer_Last) := Path_Separator;
397
      end if;
398
 
399
      Buffer (Buffer_Last + 1 .. Buffer_Last + Dir'Length) := Dir;
400
      Buffer_Last := Buffer_Last + Dir'Length;
401
   end Add_To_Path;
402
 
403
   ------------------------
404
   -- Add_To_Source_Path --
405
   ------------------------
406
 
407
   procedure Add_To_Source_Path
408
     (Source_Dirs  : String_List_Id;
409
      Shared       : Shared_Project_Tree_Data_Access;
410
      Source_Paths : in out Source_Path_Table.Instance)
411
   is
412
      Current    : String_List_Id := Source_Dirs;
413
      Source_Dir : String_Element;
414
      Add_It     : Boolean;
415
 
416
   begin
417
      --  Add each source directory
418
 
419
      while Current /= Nil_String loop
420
         Source_Dir := Shared.String_Elements.Table (Current);
421
         Add_It := True;
422
 
423
         --  Check if the source directory is already in the table
424
 
425
         for Index in
426
           Source_Path_Table.First .. Source_Path_Table.Last (Source_Paths)
427
         loop
428
            --  If it is already, no need to add it
429
 
430
            if Source_Paths.Table (Index) = Source_Dir.Value then
431
               Add_It := False;
432
               exit;
433
            end if;
434
         end loop;
435
 
436
         if Add_It then
437
            Source_Path_Table.Append (Source_Paths, Source_Dir.Display_Value);
438
         end if;
439
 
440
         --  Next source directory
441
 
442
         Current := Source_Dir.Next;
443
      end loop;
444
   end Add_To_Source_Path;
445
 
446
   --------------------------------
447
   -- Create_Config_Pragmas_File --
448
   --------------------------------
449
 
450
   procedure Create_Config_Pragmas_File
451
     (For_Project : Project_Id;
452
      In_Tree     : Project_Tree_Ref)
453
   is
454
      type Naming_Id is new Nat;
455
      package Naming_Table is new GNAT.Dynamic_Tables
456
        (Table_Component_Type => Lang_Naming_Data,
457
         Table_Index_Type     => Naming_Id,
458
         Table_Low_Bound      => 1,
459
         Table_Initial        => 5,
460
         Table_Increment      => 100);
461
 
462
      Default_Naming : constant Naming_Id := Naming_Table.First;
463
      Namings        : Naming_Table.Instance;
464
      --  Table storing the naming data for gnatmake/gprmake
465
 
466
      Buffer      : String_Access := new String (1 .. Buffer_Initial);
467
      Buffer_Last : Natural := 0;
468
 
469
      File_Name : Path_Name_Type  := No_Path;
470
      File      : File_Descriptor := Invalid_FD;
471
 
472
      Current_Naming : Naming_Id;
473
 
474
      procedure Check
475
        (Project : Project_Id;
476
         In_Tree : Project_Tree_Ref;
477
         State   : in out Integer);
478
      --  Recursive procedure that put in the config pragmas file any non
479
      --  standard naming schemes, if it is not already in the file, then call
480
      --  itself for any imported project.
481
 
482
      procedure Put (Source : Source_Id);
483
      --  Put an SFN pragma in the temporary file
484
 
485
      procedure Put (S : String);
486
      procedure Put_Line (S : String);
487
      --  Output procedures, analogous to normal Text_IO procs of same name.
488
      --  The text is put in Buffer, then it will be written into a temporary
489
      --  file with procedure Write_Temp_File below.
490
 
491
      procedure Write_Temp_File;
492
      --  Create a temporary file and put the content of the buffer in it
493
 
494
      -----------
495
      -- Check --
496
      -----------
497
 
498
      procedure Check
499
        (Project : Project_Id;
500
         In_Tree : Project_Tree_Ref;
501
         State   : in out Integer)
502
      is
503
         pragma Unreferenced (State);
504
 
505
         Lang   : constant Language_Ptr :=
506
                    Get_Language_From_Name (Project, "ada");
507
         Naming : Lang_Naming_Data;
508
         Iter   : Source_Iterator;
509
         Source : Source_Id;
510
 
511
      begin
512
         if Current_Verbosity = High then
513
            Debug_Output ("Checking project file:", Project.Name);
514
         end if;
515
 
516
         if Lang = null then
517
            if Current_Verbosity = High then
518
               Debug_Output ("Languages does not contain Ada, nothing to do");
519
            end if;
520
 
521
            return;
522
         end if;
523
 
524
         --  Visit all the files and process those that need an SFN pragma
525
 
526
         Iter := For_Each_Source (In_Tree, Project);
527
         while Element (Iter) /= No_Source loop
528
            Source := Element (Iter);
529
 
530
            if not Source.Locally_Removed
531
              and then Source.Unit /= null
532
              and then
533
                (Source.Index >= 1 or else Source.Naming_Exception /= No)
534
            then
535
               Put (Source);
536
            end if;
537
 
538
            Next (Iter);
539
         end loop;
540
 
541
         Naming := Lang.Config.Naming_Data;
542
 
543
         --  Is the naming scheme of this project one that we know?
544
 
545
         Current_Naming := Default_Naming;
546
         while Current_Naming <= Naming_Table.Last (Namings)
547
           and then Namings.Table (Current_Naming).Dot_Replacement =
548
                                                    Naming.Dot_Replacement
549
           and then Namings.Table (Current_Naming).Casing =
550
                                                    Naming.Casing
551
           and then Namings.Table (Current_Naming).Separate_Suffix =
552
                                                    Naming.Separate_Suffix
553
         loop
554
            Current_Naming := Current_Naming + 1;
555
         end loop;
556
 
557
         --  If we don't know it, add it
558
 
559
         if Current_Naming > Naming_Table.Last (Namings) then
560
            Naming_Table.Increment_Last (Namings);
561
            Namings.Table (Naming_Table.Last (Namings)) := Naming;
562
 
563
            --  Put the SFN pragmas for the naming scheme
564
 
565
            --  Spec
566
 
567
            Put_Line
568
              ("pragma Source_File_Name_Project");
569
            Put_Line
570
              ("  (Spec_File_Name  => ""*" &
571
               Get_Name_String (Naming.Spec_Suffix) & """,");
572
            Put_Line
573
              ("   Casing          => " &
574
               Image (Naming.Casing) & ",");
575
            Put_Line
576
              ("   Dot_Replacement => """ &
577
               Get_Name_String (Naming.Dot_Replacement) & """);");
578
 
579
            --  and body
580
 
581
            Put_Line
582
              ("pragma Source_File_Name_Project");
583
            Put_Line
584
              ("  (Body_File_Name  => ""*" &
585
               Get_Name_String (Naming.Body_Suffix) & """,");
586
            Put_Line
587
              ("   Casing          => " &
588
               Image (Naming.Casing) & ",");
589
            Put_Line
590
              ("   Dot_Replacement => """ &
591
               Get_Name_String (Naming.Dot_Replacement) &
592
               """);");
593
 
594
            --  and maybe separate
595
 
596
            if Naming.Body_Suffix /= Naming.Separate_Suffix then
597
               Put_Line ("pragma Source_File_Name_Project");
598
               Put_Line
599
                 ("  (Subunit_File_Name  => ""*" &
600
                  Get_Name_String (Naming.Separate_Suffix) & """,");
601
               Put_Line
602
                 ("   Casing          => " &
603
                  Image (Naming.Casing) & ",");
604
               Put_Line
605
                 ("   Dot_Replacement => """ &
606
                  Get_Name_String (Naming.Dot_Replacement) &
607
                  """);");
608
            end if;
609
         end if;
610
      end Check;
611
 
612
      ---------
613
      -- Put --
614
      ---------
615
 
616
      procedure Put (Source : Source_Id) is
617
      begin
618
         --  Put the pragma SFN for the unit kind (spec or body)
619
 
620
         Put ("pragma Source_File_Name_Project (");
621
         Put (Namet.Get_Name_String (Source.Unit.Name));
622
 
623
         if Source.Kind = Spec then
624
            Put (", Spec_File_Name => """);
625
         else
626
            Put (", Body_File_Name => """);
627
         end if;
628
 
629
         Put (Namet.Get_Name_String (Source.File));
630
         Put ("""");
631
 
632
         if Source.Index /= 0 then
633
            Put (", Index =>");
634
            Put (Source.Index'Img);
635
         end if;
636
 
637
         Put_Line (");");
638
      end Put;
639
 
640
      procedure Put (S : String) is
641
      begin
642
         Add_To_Buffer (S, Buffer, Buffer_Last);
643
 
644
         if Current_Verbosity = High then
645
            Write_Str (S);
646
         end if;
647
      end Put;
648
 
649
      --------------
650
      -- Put_Line --
651
      --------------
652
 
653
      procedure Put_Line (S : String) is
654
      begin
655
         --  Add an ASCII.LF to the string. As this config file is supposed to
656
         --  be used only by the compiler, we don't care about the characters
657
         --  for the end of line. In fact we could have put a space, but
658
         --  it is more convenient to be able to read gnat.adc during
659
         --  development, for which the ASCII.LF is fine.
660
 
661
         Put (S);
662
         Put (S => (1 => ASCII.LF));
663
      end Put_Line;
664
 
665
      ---------------------
666
      -- Write_Temp_File --
667
      ---------------------
668
 
669
      procedure Write_Temp_File is
670
         Status : Boolean := False;
671
         Last   : Natural;
672
 
673
      begin
674
         Tempdir.Create_Temp_File (File, File_Name);
675
 
676
         if File /= Invalid_FD then
677
            Last := Write (File, Buffer (1)'Address, Buffer_Last);
678
 
679
            if Last = Buffer_Last then
680
               Close (File, Status);
681
            end if;
682
         end if;
683
 
684
         if not Status then
685
            Prj.Com.Fail ("unable to create temporary file");
686
         end if;
687
      end Write_Temp_File;
688
 
689
      procedure Check_Imported_Projects is
690
        new For_Every_Project_Imported (Integer, Check);
691
 
692
      Dummy : Integer := 0;
693
 
694
   --  Start of processing for Create_Config_Pragmas_File
695
 
696
   begin
697
      if not For_Project.Config_Checked then
698
         Naming_Table.Init (Namings);
699
 
700
         --  Check the naming schemes
701
 
702
         Check_Imported_Projects
703
           (For_Project, In_Tree, Dummy, Imported_First => False);
704
 
705
         --  If there are no non standard naming scheme, issue the GNAT
706
         --  standard naming scheme. This will tell the compiler that
707
         --  a project file is used and will forbid any pragma SFN.
708
 
709
         if Buffer_Last = 0 then
710
 
711
            Put_Line ("pragma Source_File_Name_Project");
712
            Put_Line ("   (Spec_File_Name  => ""*.ads"",");
713
            Put_Line ("    Dot_Replacement => ""-"",");
714
            Put_Line ("    Casing          => lowercase);");
715
 
716
            Put_Line ("pragma Source_File_Name_Project");
717
            Put_Line ("   (Body_File_Name  => ""*.adb"",");
718
            Put_Line ("    Dot_Replacement => ""-"",");
719
            Put_Line ("    Casing          => lowercase);");
720
         end if;
721
 
722
         --  Close the temporary file
723
 
724
         Write_Temp_File;
725
 
726
         if Opt.Verbose_Mode then
727
            Write_Str ("Created configuration file """);
728
            Write_Str (Get_Name_String (File_Name));
729
            Write_Line ("""");
730
         end if;
731
 
732
         For_Project.Config_File_Name := File_Name;
733
         For_Project.Config_File_Temp := True;
734
         For_Project.Config_Checked   := True;
735
      end if;
736
 
737
      Free (Buffer);
738
   end Create_Config_Pragmas_File;
739
 
740
   --------------------
741
   -- Create_Mapping --
742
   --------------------
743
 
744
   procedure Create_Mapping (In_Tree : Project_Tree_Ref) is
745
      Data : Source_Id;
746
      Iter : Source_Iterator;
747
 
748
   begin
749
      Fmap.Reset_Tables;
750
 
751
      Iter := For_Each_Source (In_Tree);
752
      loop
753
         Data := Element (Iter);
754
         exit when Data = No_Source;
755
 
756
         if Data.Unit /= No_Unit_Index then
757
            if Data.Locally_Removed then
758
               Fmap.Add_Forbidden_File_Name (Data.File);
759
            else
760
               Fmap.Add_To_File_Map
761
                 (Unit_Name => Unit_Name_Type (Data.Unit.Name),
762
                  File_Name => Data.File,
763
                  Path_Name => File_Name_Type (Data.Path.Display_Name));
764
            end if;
765
         end if;
766
 
767
         Next (Iter);
768
      end loop;
769
   end Create_Mapping;
770
 
771
   -------------------------
772
   -- Create_Mapping_File --
773
   -------------------------
774
 
775
   procedure Create_Mapping_File
776
     (Project  : Project_Id;
777
      Language : Name_Id;
778
      In_Tree  : Project_Tree_Ref;
779
      Name     : out Path_Name_Type)
780
   is
781
      File        : File_Descriptor := Invalid_FD;
782
      Buffer      : String_Access   := new String (1 .. Buffer_Initial);
783
      Buffer_Last : Natural         := 0;
784
 
785
      procedure Put_Name_Buffer;
786
      --  Put the line contained in the Name_Buffer in the global buffer
787
 
788
      procedure Process
789
        (Project : Project_Id;
790
         In_Tree : Project_Tree_Ref;
791
         State   : in out Integer);
792
      --  Generate the mapping file for Project (not recursively)
793
 
794
      ---------------------
795
      -- Put_Name_Buffer --
796
      ---------------------
797
 
798
      procedure Put_Name_Buffer is
799
      begin
800
         if Current_Verbosity = High then
801
            Debug_Output (Name_Buffer (1 .. Name_Len));
802
         end if;
803
 
804
         Name_Len := Name_Len + 1;
805
         Name_Buffer (Name_Len) := ASCII.LF;
806
         Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
807
      end Put_Name_Buffer;
808
 
809
      -------------
810
      -- Process --
811
      -------------
812
 
813
      procedure Process
814
        (Project : Project_Id;
815
         In_Tree : Project_Tree_Ref;
816
         State   : in out Integer)
817
      is
818
         pragma Unreferenced (State);
819
 
820
         Source : Source_Id;
821
         Suffix : File_Name_Type;
822
         Iter   : Source_Iterator;
823
 
824
      begin
825
         Debug_Output ("Add mapping for project", Project.Name);
826
         Iter := For_Each_Source (In_Tree, Project, Language => Language);
827
 
828
         loop
829
            Source := Prj.Element (Iter);
830
            exit when Source = No_Source;
831
 
832
            if Source.Replaced_By = No_Source
833
              and then Source.Path.Name /= No_Path
834
              and then (Source.Language.Config.Kind = File_Based
835
                         or else Source.Unit /= No_Unit_Index)
836
            then
837
               if Source.Unit /= No_Unit_Index then
838
 
839
                  --  Put the encoded unit name in the name buffer
840
 
841
                  declare
842
                     Uname : constant String :=
843
                               Get_Name_String (Source.Unit.Name);
844
 
845
                  begin
846
                     Name_Len := 0;
847
                     for J in Uname'Range loop
848
                        if Uname (J) in Upper_Half_Character then
849
                           Store_Encoded_Character (Get_Char_Code (Uname (J)));
850
                        else
851
                           Add_Char_To_Name_Buffer (Uname (J));
852
                        end if;
853
                     end loop;
854
                  end;
855
 
856
                  if Source.Language.Config.Kind = Unit_Based then
857
 
858
                     --  ??? Mapping_Spec_Suffix could be set in the case of
859
                     --  gnatmake as well
860
 
861
                     Add_Char_To_Name_Buffer ('%');
862
 
863
                     if Source.Kind = Spec then
864
                        Add_Char_To_Name_Buffer ('s');
865
                     else
866
                        Add_Char_To_Name_Buffer ('b');
867
                     end if;
868
 
869
                  else
870
                     case Source.Kind is
871
                        when Spec =>
872
                           Suffix :=
873
                             Source.Language.Config.Mapping_Spec_Suffix;
874
                        when Impl | Sep =>
875
                           Suffix :=
876
                             Source.Language.Config.Mapping_Body_Suffix;
877
                     end case;
878
 
879
                     if Suffix /= No_File then
880
                        Add_Str_To_Name_Buffer (Get_Name_String (Suffix));
881
                     end if;
882
                  end if;
883
 
884
                  Put_Name_Buffer;
885
               end if;
886
 
887
               Get_Name_String (Source.Display_File);
888
               Put_Name_Buffer;
889
 
890
               if Source.Locally_Removed then
891
                  Name_Len := 1;
892
                  Name_Buffer (1) := '/';
893
               else
894
                  Get_Name_String (Source.Path.Display_Name);
895
               end if;
896
 
897
               Put_Name_Buffer;
898
            end if;
899
 
900
            Next (Iter);
901
         end loop;
902
      end Process;
903
 
904
      procedure For_Every_Imported_Project is new
905
        For_Every_Project_Imported (State => Integer, Action => Process);
906
 
907
      --  Local variables
908
 
909
      Dummy : Integer := 0;
910
 
911
   --  Start of processing for Create_Mapping_File
912
 
913
   begin
914
      if Current_Verbosity = High then
915
         Debug_Output ("Create mapping file for", Debug_Name (In_Tree));
916
      end if;
917
 
918
      Create_Temp_File (In_Tree.Shared, File, Name, "mapping");
919
 
920
      if Current_Verbosity = High then
921
         Debug_Increase_Indent ("Create mapping file ", Name_Id (Name));
922
      end if;
923
 
924
      For_Every_Imported_Project
925
        (Project, In_Tree, Dummy, Include_Aggregated => False);
926
 
927
      declare
928
         Last   : Natural;
929
         Status : Boolean := False;
930
 
931
      begin
932
         if File /= Invalid_FD then
933
            Last := Write (File, Buffer (1)'Address, Buffer_Last);
934
 
935
            if Last = Buffer_Last then
936
               GNAT.OS_Lib.Close (File, Status);
937
            end if;
938
         end if;
939
 
940
         if not Status then
941
            Prj.Com.Fail ("could not write mapping file");
942
         end if;
943
      end;
944
 
945
      Free (Buffer);
946
 
947
      Debug_Decrease_Indent ("Done create mapping file");
948
   end Create_Mapping_File;
949
 
950
   ----------------------
951
   -- Create_Temp_File --
952
   ----------------------
953
 
954
   procedure Create_Temp_File
955
     (Shared    : Shared_Project_Tree_Data_Access;
956
      Path_FD   : out File_Descriptor;
957
      Path_Name : out Path_Name_Type;
958
      File_Use  : String)
959
   is
960
   begin
961
      Tempdir.Create_Temp_File (Path_FD, Path_Name);
962
 
963
      if Path_Name /= No_Path then
964
         if Current_Verbosity = High then
965
            Write_Line ("Create temp file (" & File_Use & ") "
966
                        & Get_Name_String (Path_Name));
967
         end if;
968
 
969
         Record_Temp_File (Shared, Path_Name);
970
 
971
      else
972
         Prj.Com.Fail
973
           ("unable to create temporary " & File_Use & " file");
974
      end if;
975
   end Create_Temp_File;
976
 
977
   --------------------------
978
   -- Create_New_Path_File --
979
   --------------------------
980
 
981
   procedure Create_New_Path_File
982
     (Shared    : Shared_Project_Tree_Data_Access;
983
      Path_FD   : out File_Descriptor;
984
      Path_Name : out Path_Name_Type)
985
   is
986
   begin
987
      Create_Temp_File (Shared, Path_FD, Path_Name, "path file");
988
   end Create_New_Path_File;
989
 
990
   ------------------------------------
991
   -- File_Name_Of_Library_Unit_Body --
992
   ------------------------------------
993
 
994
   function File_Name_Of_Library_Unit_Body
995
     (Name              : String;
996
      Project           : Project_Id;
997
      In_Tree           : Project_Tree_Ref;
998
      Main_Project_Only : Boolean := True;
999
      Full_Path         : Boolean := False) return String
1000
   is
1001
 
1002
      Lang          : constant Language_Ptr :=
1003
                        Get_Language_From_Name (Project, "ada");
1004
      The_Project   : Project_Id := Project;
1005
      Original_Name : String := Name;
1006
 
1007
      Unit              : Unit_Index;
1008
      The_Original_Name : Name_Id;
1009
      The_Spec_Name     : Name_Id;
1010
      The_Body_Name     : Name_Id;
1011
 
1012
   begin
1013
      --  ??? Same block in Project_Of
1014
      Canonical_Case_File_Name (Original_Name);
1015
      Name_Len := Original_Name'Length;
1016
      Name_Buffer (1 .. Name_Len) := Original_Name;
1017
      The_Original_Name := Name_Find;
1018
 
1019
      if Lang /= null then
1020
         declare
1021
            Naming : constant Lang_Naming_Data := Lang.Config.Naming_Data;
1022
            Extended_Spec_Name : String :=
1023
                                   Name & Namet.Get_Name_String
1024
                                            (Naming.Spec_Suffix);
1025
            Extended_Body_Name : String :=
1026
                                   Name & Namet.Get_Name_String
1027
                                            (Naming.Body_Suffix);
1028
 
1029
         begin
1030
            Canonical_Case_File_Name (Extended_Spec_Name);
1031
            Name_Len := Extended_Spec_Name'Length;
1032
            Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
1033
            The_Spec_Name := Name_Find;
1034
 
1035
            Canonical_Case_File_Name (Extended_Body_Name);
1036
            Name_Len := Extended_Body_Name'Length;
1037
            Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
1038
            The_Body_Name := Name_Find;
1039
         end;
1040
 
1041
      else
1042
         Name_Len := Name'Length;
1043
         Name_Buffer (1 .. Name_Len) := Name;
1044
         Canonical_Case_File_Name (Name_Buffer);
1045
         The_Spec_Name := Name_Find;
1046
         The_Body_Name := The_Spec_Name;
1047
      end if;
1048
 
1049
      if Current_Verbosity = High then
1050
         Write_Str  ("Looking for file name of """);
1051
         Write_Str  (Name);
1052
         Write_Char ('"');
1053
         Write_Eol;
1054
         Write_Str  ("   Extended Spec Name = """);
1055
         Write_Str  (Get_Name_String (The_Spec_Name));
1056
         Write_Char ('"');
1057
         Write_Eol;
1058
         Write_Str  ("   Extended Body Name = """);
1059
         Write_Str  (Get_Name_String (The_Body_Name));
1060
         Write_Char ('"');
1061
         Write_Eol;
1062
      end if;
1063
 
1064
      --  For extending project, search in the extended project if the source
1065
      --  is not found. For non extending projects, this loop will be run only
1066
      --  once.
1067
 
1068
      loop
1069
         --  Loop through units
1070
 
1071
         Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1072
         while Unit /= null loop
1073
            --  Check for body
1074
 
1075
            if not Main_Project_Only
1076
              or else
1077
                (Unit.File_Names (Impl) /= null
1078
                 and then Unit.File_Names (Impl).Project = The_Project)
1079
            then
1080
               declare
1081
                  Current_Name : File_Name_Type;
1082
               begin
1083
                  --  Case of a body present
1084
 
1085
                  if Unit.File_Names (Impl) /= null then
1086
                     Current_Name := Unit.File_Names (Impl).File;
1087
 
1088
                     if Current_Verbosity = High then
1089
                        Write_Str  ("   Comparing with """);
1090
                        Write_Str  (Get_Name_String (Current_Name));
1091
                        Write_Char ('"');
1092
                        Write_Eol;
1093
                     end if;
1094
 
1095
                     --  If it has the name of the original name, return the
1096
                     --  original name.
1097
 
1098
                     if Unit.Name = The_Original_Name
1099
                       or else
1100
                         Current_Name = File_Name_Type (The_Original_Name)
1101
                     then
1102
                        if Current_Verbosity = High then
1103
                           Write_Line ("   OK");
1104
                        end if;
1105
 
1106
                        if Full_Path then
1107
                           return Get_Name_String
1108
                             (Unit.File_Names (Impl).Path.Name);
1109
 
1110
                        else
1111
                           return Get_Name_String (Current_Name);
1112
                        end if;
1113
 
1114
                        --  If it has the name of the extended body name,
1115
                        --  return the extended body name
1116
 
1117
                     elsif Current_Name = File_Name_Type (The_Body_Name) then
1118
                        if Current_Verbosity = High then
1119
                           Write_Line ("   OK");
1120
                        end if;
1121
 
1122
                        if Full_Path then
1123
                           return Get_Name_String
1124
                             (Unit.File_Names (Impl).Path.Name);
1125
 
1126
                        else
1127
                           return Get_Name_String (The_Body_Name);
1128
                        end if;
1129
 
1130
                     else
1131
                        if Current_Verbosity = High then
1132
                           Write_Line ("   not good");
1133
                        end if;
1134
                     end if;
1135
                  end if;
1136
               end;
1137
            end if;
1138
 
1139
            --  Check for spec
1140
 
1141
            if not Main_Project_Only
1142
              or else (Unit.File_Names (Spec) /= null
1143
                        and then Unit.File_Names (Spec).Project = The_Project)
1144
            then
1145
               declare
1146
                  Current_Name : File_Name_Type;
1147
 
1148
               begin
1149
                  --  Case of spec present
1150
 
1151
                  if Unit.File_Names (Spec) /= null then
1152
                     Current_Name := Unit.File_Names (Spec).File;
1153
                     if Current_Verbosity = High then
1154
                        Write_Str  ("   Comparing with """);
1155
                        Write_Str  (Get_Name_String (Current_Name));
1156
                        Write_Char ('"');
1157
                        Write_Eol;
1158
                     end if;
1159
 
1160
                     --  If name same as original name, return original name
1161
 
1162
                     if Unit.Name = The_Original_Name
1163
                       or else
1164
                         Current_Name = File_Name_Type (The_Original_Name)
1165
                     then
1166
                        if Current_Verbosity = High then
1167
                           Write_Line ("   OK");
1168
                        end if;
1169
 
1170
                        if Full_Path then
1171
                           return Get_Name_String
1172
                             (Unit.File_Names (Spec).Path.Name);
1173
                        else
1174
                           return Get_Name_String (Current_Name);
1175
                        end if;
1176
 
1177
                        --  If it has the same name as the extended spec name,
1178
                        --  return the extended spec name.
1179
 
1180
                     elsif Current_Name = File_Name_Type (The_Spec_Name) then
1181
                        if Current_Verbosity = High then
1182
                           Write_Line ("   OK");
1183
                        end if;
1184
 
1185
                        if Full_Path then
1186
                           return Get_Name_String
1187
                             (Unit.File_Names (Spec).Path.Name);
1188
                        else
1189
                           return Get_Name_String (The_Spec_Name);
1190
                        end if;
1191
 
1192
                     else
1193
                        if Current_Verbosity = High then
1194
                           Write_Line ("   not good");
1195
                        end if;
1196
                     end if;
1197
                  end if;
1198
               end;
1199
            end if;
1200
 
1201
            Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1202
         end loop;
1203
 
1204
         --  If we are not in an extending project, give up
1205
 
1206
         exit when not Main_Project_Only
1207
           or else The_Project.Extends = No_Project;
1208
 
1209
         --  Otherwise, look in the project we are extending
1210
 
1211
         The_Project := The_Project.Extends;
1212
      end loop;
1213
 
1214
      --  We don't know this file name, return an empty string
1215
 
1216
      return "";
1217
   end File_Name_Of_Library_Unit_Body;
1218
 
1219
   -------------------------
1220
   -- For_All_Object_Dirs --
1221
   -------------------------
1222
 
1223
   procedure For_All_Object_Dirs
1224
     (Project : Project_Id;
1225
      Tree    : Project_Tree_Ref)
1226
   is
1227
      procedure For_Project
1228
        (Prj   : Project_Id;
1229
         Tree  : Project_Tree_Ref;
1230
         Dummy : in out Integer);
1231
      --  Get all object directories of Prj
1232
 
1233
      -----------------
1234
      -- For_Project --
1235
      -----------------
1236
 
1237
      procedure For_Project
1238
        (Prj   : Project_Id;
1239
         Tree  : Project_Tree_Ref;
1240
         Dummy : in out Integer)
1241
      is
1242
         pragma Unreferenced (Dummy, Tree);
1243
 
1244
      begin
1245
         --  ??? Set_Ada_Paths has a different behavior for library project
1246
         --  files, should we have the same ?
1247
 
1248
         if Prj.Object_Directory /= No_Path_Information then
1249
            Get_Name_String (Prj.Object_Directory.Display_Name);
1250
            Action (Name_Buffer (1 .. Name_Len));
1251
         end if;
1252
      end For_Project;
1253
 
1254
      procedure Get_Object_Dirs is
1255
        new For_Every_Project_Imported (Integer, For_Project);
1256
      Dummy : Integer := 1;
1257
 
1258
   --  Start of processing for For_All_Object_Dirs
1259
 
1260
   begin
1261
      Get_Object_Dirs (Project, Tree, Dummy);
1262
   end For_All_Object_Dirs;
1263
 
1264
   -------------------------
1265
   -- For_All_Source_Dirs --
1266
   -------------------------
1267
 
1268
   procedure For_All_Source_Dirs
1269
     (Project : Project_Id;
1270
      In_Tree : Project_Tree_Ref)
1271
   is
1272
      procedure For_Project
1273
        (Prj     : Project_Id;
1274
         In_Tree : Project_Tree_Ref;
1275
         Dummy   : in out Integer);
1276
      --  Get all object directories of Prj
1277
 
1278
      -----------------
1279
      -- For_Project --
1280
      -----------------
1281
 
1282
      procedure For_Project
1283
        (Prj     : Project_Id;
1284
         In_Tree : Project_Tree_Ref;
1285
         Dummy   : in out Integer)
1286
      is
1287
         pragma Unreferenced (Dummy);
1288
 
1289
         Current    : String_List_Id := Prj.Source_Dirs;
1290
         The_String : String_Element;
1291
 
1292
      begin
1293
         --  If there are Ada sources, call action with the name of every
1294
         --  source directory.
1295
 
1296
         if Has_Ada_Sources (Prj) then
1297
            while Current /= Nil_String loop
1298
               The_String := In_Tree.Shared.String_Elements.Table (Current);
1299
               Action (Get_Name_String (The_String.Display_Value));
1300
               Current := The_String.Next;
1301
            end loop;
1302
         end if;
1303
      end For_Project;
1304
 
1305
      procedure Get_Source_Dirs is
1306
        new For_Every_Project_Imported (Integer, For_Project);
1307
      Dummy : Integer := 1;
1308
 
1309
   --  Start of processing for For_All_Source_Dirs
1310
 
1311
   begin
1312
      Get_Source_Dirs (Project, In_Tree, Dummy);
1313
   end For_All_Source_Dirs;
1314
 
1315
   -------------------
1316
   -- Get_Reference --
1317
   -------------------
1318
 
1319
   procedure Get_Reference
1320
     (Source_File_Name : String;
1321
      In_Tree          : Project_Tree_Ref;
1322
      Project          : out Project_Id;
1323
      Path             : out Path_Name_Type)
1324
   is
1325
   begin
1326
      --  Body below could use some comments ???
1327
 
1328
      if Current_Verbosity > Default then
1329
         Write_Str ("Getting Reference_Of (""");
1330
         Write_Str (Source_File_Name);
1331
         Write_Str (""") ... ");
1332
      end if;
1333
 
1334
      declare
1335
         Original_Name : String := Source_File_Name;
1336
         Unit          : Unit_Index;
1337
 
1338
      begin
1339
         Canonical_Case_File_Name (Original_Name);
1340
         Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1341
 
1342
         while Unit /= null loop
1343
            if Unit.File_Names (Spec) /= null
1344
              and then not Unit.File_Names (Spec).Locally_Removed
1345
              and then Unit.File_Names (Spec).File /= No_File
1346
              and then
1347
                (Namet.Get_Name_String
1348
                   (Unit.File_Names (Spec).File) = Original_Name
1349
                 or else (Unit.File_Names (Spec).Path /= No_Path_Information
1350
                          and then
1351
                            Namet.Get_Name_String
1352
                               (Unit.File_Names (Spec).Path.Name) =
1353
                                                           Original_Name))
1354
            then
1355
               Project :=
1356
                 Ultimate_Extending_Project_Of
1357
                   (Unit.File_Names (Spec).Project);
1358
               Path := Unit.File_Names (Spec).Path.Display_Name;
1359
 
1360
               if Current_Verbosity > Default then
1361
                  Write_Str ("Done: Spec.");
1362
                  Write_Eol;
1363
               end if;
1364
 
1365
               return;
1366
 
1367
            elsif Unit.File_Names (Impl) /= null
1368
              and then Unit.File_Names (Impl).File /= No_File
1369
              and then not Unit.File_Names (Impl).Locally_Removed
1370
              and then
1371
                (Namet.Get_Name_String
1372
                   (Unit.File_Names (Impl).File) = Original_Name
1373
                  or else (Unit.File_Names (Impl).Path /= No_Path_Information
1374
                            and then Namet.Get_Name_String
1375
                                       (Unit.File_Names (Impl).Path.Name) =
1376
                                                              Original_Name))
1377
            then
1378
               Project :=
1379
                 Ultimate_Extending_Project_Of
1380
                   (Unit.File_Names (Impl).Project);
1381
               Path := Unit.File_Names (Impl).Path.Display_Name;
1382
 
1383
               if Current_Verbosity > Default then
1384
                  Write_Str ("Done: Body.");
1385
                  Write_Eol;
1386
               end if;
1387
 
1388
               return;
1389
            end if;
1390
 
1391
            Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1392
         end loop;
1393
      end;
1394
 
1395
      Project := No_Project;
1396
      Path    := No_Path;
1397
 
1398
      if Current_Verbosity > Default then
1399
         Write_Str ("Cannot be found.");
1400
         Write_Eol;
1401
      end if;
1402
   end Get_Reference;
1403
 
1404
   ----------------------
1405
   -- Get_Runtime_Path --
1406
   ----------------------
1407
 
1408
   function Get_Runtime_Path
1409
     (Self : Project_Search_Path;
1410
      Name : String) return String_Access
1411
   is
1412
      function Is_Base_Name (Path : String) return Boolean;
1413
      --  Returns True if Path has no directory separator
1414
 
1415
      ------------------
1416
      -- Is_Base_Name --
1417
      ------------------
1418
 
1419
      function Is_Base_Name (Path : String) return Boolean is
1420
      begin
1421
         for J in Path'Range loop
1422
            if Path (J) = Directory_Separator or else Path (J) = '/' then
1423
               return False;
1424
            end if;
1425
         end loop;
1426
 
1427
         return True;
1428
      end Is_Base_Name;
1429
 
1430
      function Find_Rts_In_Path is new Prj.Env.Find_Name_In_Path
1431
        (Check_Filename => Is_Directory);
1432
 
1433
      --  Start of processing for Get_Runtime_Path
1434
 
1435
   begin
1436
      if not Is_Base_Name (Name) then
1437
         return Find_Rts_In_Path (Self, Name);
1438
      else
1439
         return null;
1440
      end if;
1441
   end Get_Runtime_Path;
1442
 
1443
   ----------------
1444
   -- Initialize --
1445
   ----------------
1446
 
1447
   procedure Initialize (In_Tree : Project_Tree_Ref) is
1448
   begin
1449
      In_Tree.Shared.Private_Part.Current_Source_Path_File := No_Path;
1450
      In_Tree.Shared.Private_Part.Current_Object_Path_File := No_Path;
1451
   end Initialize;
1452
 
1453
   -------------------
1454
   -- Print_Sources --
1455
   -------------------
1456
 
1457
   --  Could use some comments in this body ???
1458
 
1459
   procedure Print_Sources (In_Tree : Project_Tree_Ref) is
1460
      Unit : Unit_Index;
1461
 
1462
   begin
1463
      Write_Line ("List of Sources:");
1464
 
1465
      Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1466
 
1467
      while Unit /= No_Unit_Index loop
1468
         Write_Str  ("   ");
1469
         Write_Line (Namet.Get_Name_String (Unit.Name));
1470
 
1471
         if Unit.File_Names (Spec).File /= No_File then
1472
            if Unit.File_Names (Spec).Project = No_Project then
1473
               Write_Line ("   No project");
1474
 
1475
            else
1476
               Write_Str  ("   Project: ");
1477
               Get_Name_String
1478
                 (Unit.File_Names (Spec).Project.Path.Name);
1479
               Write_Line (Name_Buffer (1 .. Name_Len));
1480
            end if;
1481
 
1482
            Write_Str  ("      spec: ");
1483
            Write_Line
1484
              (Namet.Get_Name_String
1485
               (Unit.File_Names (Spec).File));
1486
         end if;
1487
 
1488
         if Unit.File_Names (Impl).File /= No_File then
1489
            if Unit.File_Names (Impl).Project = No_Project then
1490
               Write_Line ("   No project");
1491
 
1492
            else
1493
               Write_Str  ("   Project: ");
1494
               Get_Name_String
1495
                 (Unit.File_Names (Impl).Project.Path.Name);
1496
               Write_Line (Name_Buffer (1 .. Name_Len));
1497
            end if;
1498
 
1499
            Write_Str  ("      body: ");
1500
            Write_Line
1501
              (Namet.Get_Name_String (Unit.File_Names (Impl).File));
1502
         end if;
1503
 
1504
         Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1505
      end loop;
1506
 
1507
      Write_Line ("end of List of Sources.");
1508
   end Print_Sources;
1509
 
1510
   ----------------
1511
   -- Project_Of --
1512
   ----------------
1513
 
1514
   function Project_Of
1515
     (Name         : String;
1516
      Main_Project : Project_Id;
1517
      In_Tree      : Project_Tree_Ref) return Project_Id
1518
   is
1519
      Result : Project_Id := No_Project;
1520
 
1521
      Original_Name : String := Name;
1522
 
1523
      Lang : constant Language_Ptr :=
1524
               Get_Language_From_Name (Main_Project, "ada");
1525
 
1526
      Unit : Unit_Index;
1527
 
1528
      Current_Name      : File_Name_Type;
1529
      The_Original_Name : File_Name_Type;
1530
      The_Spec_Name     : File_Name_Type;
1531
      The_Body_Name     : File_Name_Type;
1532
 
1533
   begin
1534
      --  ??? Same block in File_Name_Of_Library_Unit_Body
1535
      Canonical_Case_File_Name (Original_Name);
1536
      Name_Len := Original_Name'Length;
1537
      Name_Buffer (1 .. Name_Len) := Original_Name;
1538
      The_Original_Name := Name_Find;
1539
 
1540
      if Lang /= null then
1541
         declare
1542
            Naming : Lang_Naming_Data renames Lang.Config.Naming_Data;
1543
            Extended_Spec_Name : String :=
1544
                                   Name & Namet.Get_Name_String
1545
                                            (Naming.Spec_Suffix);
1546
            Extended_Body_Name : String :=
1547
                                   Name & Namet.Get_Name_String
1548
                                            (Naming.Body_Suffix);
1549
 
1550
         begin
1551
            Canonical_Case_File_Name (Extended_Spec_Name);
1552
            Name_Len := Extended_Spec_Name'Length;
1553
            Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
1554
            The_Spec_Name := Name_Find;
1555
 
1556
            Canonical_Case_File_Name (Extended_Body_Name);
1557
            Name_Len := Extended_Body_Name'Length;
1558
            Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
1559
            The_Body_Name := Name_Find;
1560
         end;
1561
 
1562
      else
1563
         The_Spec_Name := The_Original_Name;
1564
         The_Body_Name := The_Original_Name;
1565
      end if;
1566
 
1567
      Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1568
      while Unit /= null loop
1569
 
1570
         --  Case of a body present
1571
 
1572
         if Unit.File_Names (Impl) /= null then
1573
            Current_Name := Unit.File_Names (Impl).File;
1574
 
1575
            --  If it has the name of the original name or the body name,
1576
            --  we have found the project.
1577
 
1578
            if Unit.Name = Name_Id (The_Original_Name)
1579
              or else Current_Name = The_Original_Name
1580
              or else Current_Name = The_Body_Name
1581
            then
1582
               Result := Unit.File_Names (Impl).Project;
1583
               exit;
1584
            end if;
1585
         end if;
1586
 
1587
         --  Check for spec
1588
 
1589
         if Unit.File_Names (Spec) /= null then
1590
            Current_Name := Unit.File_Names (Spec).File;
1591
 
1592
            --  If name same as the original name, or the spec name, we have
1593
            --  found the project.
1594
 
1595
            if Unit.Name = Name_Id (The_Original_Name)
1596
              or else Current_Name = The_Original_Name
1597
              or else Current_Name = The_Spec_Name
1598
            then
1599
               Result := Unit.File_Names (Spec).Project;
1600
               exit;
1601
            end if;
1602
         end if;
1603
 
1604
         Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1605
      end loop;
1606
 
1607
      return Ultimate_Extending_Project_Of (Result);
1608
   end Project_Of;
1609
 
1610
   -------------------
1611
   -- Set_Ada_Paths --
1612
   -------------------
1613
 
1614
   procedure Set_Ada_Paths
1615
     (Project             : Project_Id;
1616
      In_Tree             : Project_Tree_Ref;
1617
      Including_Libraries : Boolean;
1618
      Include_Path        : Boolean := True;
1619
      Objects_Path        : Boolean := True)
1620
 
1621
   is
1622
      Shared : constant Shared_Project_Tree_Data_Access := In_Tree.Shared;
1623
 
1624
      Source_Paths : Source_Path_Table.Instance;
1625
      Object_Paths : Object_Path_Table.Instance;
1626
      --  List of source or object dirs. Only computed the first time this
1627
      --  procedure is called (since Source_FD is then reused)
1628
 
1629
      Source_FD : File_Descriptor := Invalid_FD;
1630
      Object_FD : File_Descriptor := Invalid_FD;
1631
      --  The temporary files to store the paths. These are only created the
1632
      --  first time this procedure is called, and reused from then on.
1633
 
1634
      Process_Source_Dirs : Boolean := False;
1635
      Process_Object_Dirs : Boolean := False;
1636
 
1637
      Status : Boolean;
1638
      --  For calls to Close
1639
 
1640
      Last        : Natural;
1641
      Buffer      : String_Access := new String (1 .. Buffer_Initial);
1642
      Buffer_Last : Natural := 0;
1643
 
1644
      procedure Recursive_Add
1645
        (Project : Project_Id;
1646
         In_Tree : Project_Tree_Ref;
1647
         Dummy   : in out Boolean);
1648
      --  Recursive procedure to add the source/object paths of extended/
1649
      --  imported projects.
1650
 
1651
      -------------------
1652
      -- Recursive_Add --
1653
      -------------------
1654
 
1655
      procedure Recursive_Add
1656
        (Project : Project_Id;
1657
         In_Tree : Project_Tree_Ref;
1658
         Dummy   : in out Boolean)
1659
      is
1660
         pragma Unreferenced (Dummy, In_Tree);
1661
 
1662
         Path : Path_Name_Type;
1663
 
1664
      begin
1665
         --  ??? This is almost the equivalent of For_All_Source_Dirs
1666
 
1667
         if Process_Source_Dirs then
1668
 
1669
            --  Add to path all source directories of this project if there are
1670
            --  Ada sources.
1671
 
1672
            if Has_Ada_Sources (Project) then
1673
               Add_To_Source_Path (Project.Source_Dirs, Shared, Source_Paths);
1674
            end if;
1675
         end if;
1676
 
1677
         if Process_Object_Dirs then
1678
            Path := Get_Object_Directory
1679
              (Project,
1680
               Including_Libraries => Including_Libraries,
1681
               Only_If_Ada         => True);
1682
 
1683
            if Path /= No_Path then
1684
               Add_To_Object_Path (Path, Object_Paths);
1685
            end if;
1686
         end if;
1687
      end Recursive_Add;
1688
 
1689
      procedure For_All_Projects is
1690
        new For_Every_Project_Imported (Boolean, Recursive_Add);
1691
 
1692
      Dummy : Boolean := False;
1693
 
1694
   --  Start of processing for Set_Ada_Paths
1695
 
1696
   begin
1697
      --  If it is the first time we call this procedure for this project,
1698
      --  compute the source path and/or the object path.
1699
 
1700
      if Include_Path and then Project.Include_Path_File = No_Path then
1701
         Source_Path_Table.Init (Source_Paths);
1702
         Process_Source_Dirs := True;
1703
         Create_New_Path_File (Shared, Source_FD, Project.Include_Path_File);
1704
      end if;
1705
 
1706
      --  For the object path, we make a distinction depending on
1707
      --  Including_Libraries.
1708
 
1709
      if Objects_Path and Including_Libraries then
1710
         if Project.Objects_Path_File_With_Libs = No_Path then
1711
            Object_Path_Table.Init (Object_Paths);
1712
            Process_Object_Dirs := True;
1713
            Create_New_Path_File
1714
              (Shared, Object_FD, Project.Objects_Path_File_With_Libs);
1715
         end if;
1716
 
1717
      elsif Objects_Path then
1718
         if Project.Objects_Path_File_Without_Libs = No_Path then
1719
            Object_Path_Table.Init (Object_Paths);
1720
            Process_Object_Dirs := True;
1721
            Create_New_Path_File
1722
              (Shared, Object_FD, Project.Objects_Path_File_Without_Libs);
1723
         end if;
1724
      end if;
1725
 
1726
      --  If there is something to do, set Seen to False for all projects,
1727
      --  then call the recursive procedure Add for Project.
1728
 
1729
      if Process_Source_Dirs or Process_Object_Dirs then
1730
         For_All_Projects (Project, In_Tree, Dummy);
1731
      end if;
1732
 
1733
      --  Write and close any file that has been created. Source_FD is not set
1734
      --  when this subprogram is called a second time or more, since we reuse
1735
      --  the previous version of the file.
1736
 
1737
      if Source_FD /= Invalid_FD then
1738
         Buffer_Last := 0;
1739
 
1740
         for Index in
1741
           Source_Path_Table.First .. Source_Path_Table.Last (Source_Paths)
1742
         loop
1743
            Get_Name_String (Source_Paths.Table (Index));
1744
            Name_Len := Name_Len + 1;
1745
            Name_Buffer (Name_Len) := ASCII.LF;
1746
            Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
1747
         end loop;
1748
 
1749
         Last := Write (Source_FD, Buffer (1)'Address, Buffer_Last);
1750
 
1751
         if Last = Buffer_Last then
1752
            Close (Source_FD, Status);
1753
 
1754
         else
1755
            Status := False;
1756
         end if;
1757
 
1758
         if not Status then
1759
            Prj.Com.Fail ("could not write temporary file");
1760
         end if;
1761
      end if;
1762
 
1763
      if Object_FD /= Invalid_FD then
1764
         Buffer_Last := 0;
1765
 
1766
         for Index in
1767
           Object_Path_Table.First .. Object_Path_Table.Last (Object_Paths)
1768
         loop
1769
            Get_Name_String (Object_Paths.Table (Index));
1770
            Name_Len := Name_Len + 1;
1771
            Name_Buffer (Name_Len) := ASCII.LF;
1772
            Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
1773
         end loop;
1774
 
1775
         Last := Write (Object_FD, Buffer (1)'Address, Buffer_Last);
1776
 
1777
         if Last = Buffer_Last then
1778
            Close (Object_FD, Status);
1779
         else
1780
            Status := False;
1781
         end if;
1782
 
1783
         if not Status then
1784
            Prj.Com.Fail ("could not write temporary file");
1785
         end if;
1786
      end if;
1787
 
1788
      --  Set the env vars, if they need to be changed, and set the
1789
      --  corresponding flags.
1790
 
1791
      if Include_Path
1792
        and then
1793
          Shared.Private_Part.Current_Source_Path_File /=
1794
            Project.Include_Path_File
1795
      then
1796
         Shared.Private_Part.Current_Source_Path_File :=
1797
           Project.Include_Path_File;
1798
         Set_Path_File_Var
1799
           (Project_Include_Path_File,
1800
            Get_Name_String (Shared.Private_Part.Current_Source_Path_File));
1801
      end if;
1802
 
1803
      if Objects_Path then
1804
         if Including_Libraries then
1805
            if Shared.Private_Part.Current_Object_Path_File /=
1806
              Project.Objects_Path_File_With_Libs
1807
            then
1808
               Shared.Private_Part.Current_Object_Path_File :=
1809
                 Project.Objects_Path_File_With_Libs;
1810
               Set_Path_File_Var
1811
                 (Project_Objects_Path_File,
1812
                  Get_Name_String
1813
                    (Shared.Private_Part.Current_Object_Path_File));
1814
            end if;
1815
 
1816
         else
1817
            if Shared.Private_Part.Current_Object_Path_File /=
1818
              Project.Objects_Path_File_Without_Libs
1819
            then
1820
               Shared.Private_Part.Current_Object_Path_File :=
1821
                 Project.Objects_Path_File_Without_Libs;
1822
               Set_Path_File_Var
1823
                 (Project_Objects_Path_File,
1824
                  Get_Name_String
1825
                    (Shared.Private_Part.Current_Object_Path_File));
1826
            end if;
1827
         end if;
1828
      end if;
1829
 
1830
      Free (Buffer);
1831
   end Set_Ada_Paths;
1832
 
1833
   ---------------------
1834
   -- Add_Directories --
1835
   ---------------------
1836
 
1837
   procedure Add_Directories
1838
     (Self : in out Project_Search_Path;
1839
      Path : String)
1840
   is
1841
      Tmp : String_Access;
1842
   begin
1843
      if Self.Path = null then
1844
         Self.Path := new String'(Uninitialized_Prefix & Path);
1845
      else
1846
         Tmp := Self.Path;
1847
         Self.Path := new String'(Tmp.all & Path_Separator & Path);
1848
         Free (Tmp);
1849
      end if;
1850
 
1851
      if Current_Verbosity = High then
1852
         Debug_Output ("Adding directories to Project_Path: """
1853
                       & Path & '"');
1854
      end if;
1855
   end Add_Directories;
1856
 
1857
   --------------------
1858
   -- Is_Initialized --
1859
   --------------------
1860
 
1861
   function Is_Initialized (Self : Project_Search_Path) return Boolean is
1862
   begin
1863
      return Self.Path /= null
1864
        and then (Self.Path'Length = 0
1865
                   or else Self.Path (Self.Path'First) /= '#');
1866
   end Is_Initialized;
1867
 
1868
   ----------------------
1869
   -- Initialize_Empty --
1870
   ----------------------
1871
 
1872
   procedure Initialize_Empty (Self : in out Project_Search_Path) is
1873
   begin
1874
      Free (Self.Path);
1875
      Self.Path := new String'("");
1876
   end Initialize_Empty;
1877
 
1878
   -------------------------------------
1879
   -- Initialize_Default_Project_Path --
1880
   -------------------------------------
1881
 
1882
   procedure Initialize_Default_Project_Path
1883
     (Self        : in out Project_Search_Path;
1884
      Target_Name : String)
1885
   is
1886
      Add_Default_Dir : Boolean := True;
1887
      First           : Positive;
1888
      Last            : Positive;
1889
      New_Len         : Positive;
1890
      New_Last        : Positive;
1891
 
1892
      Ada_Project_Path : constant String := "ADA_PROJECT_PATH";
1893
      Gpr_Project_Path : constant String := "GPR_PROJECT_PATH";
1894
      --  Name of alternate env. variable that contain path name(s) of
1895
      --  directories where project files may reside. GPR_PROJECT_PATH has
1896
      --  precedence over ADA_PROJECT_PATH.
1897
 
1898
      Gpr_Prj_Path : String_Access;
1899
      Ada_Prj_Path : String_Access;
1900
      --  The path name(s) of directories where project files may reside.
1901
      --  May be empty.
1902
 
1903
   begin
1904
      if Is_Initialized (Self) then
1905
         return;
1906
      end if;
1907
 
1908
      --  The current directory is always first in the search path. Since the
1909
      --  Project_Path currently starts with '#:' as a sign that it isn't
1910
      --  initialized, we simply replace '#' with '.'
1911
 
1912
      if Self.Path = null then
1913
         Self.Path := new String'('.' & Path_Separator);
1914
      else
1915
         Self.Path (Self.Path'First) := '.';
1916
      end if;
1917
 
1918
      --  Then the reset of the project path (if any) currently contains the
1919
      --  directories added through Add_Search_Project_Directory
1920
 
1921
      --  If environment variables are defined and not empty, add their content
1922
 
1923
      Gpr_Prj_Path := Getenv (Gpr_Project_Path);
1924
      Ada_Prj_Path := Getenv (Ada_Project_Path);
1925
 
1926
      if Gpr_Prj_Path.all /= "" then
1927
         Add_Directories (Self, Gpr_Prj_Path.all);
1928
      end if;
1929
 
1930
      Free (Gpr_Prj_Path);
1931
 
1932
      if Ada_Prj_Path.all /= "" then
1933
         Add_Directories (Self, Ada_Prj_Path.all);
1934
      end if;
1935
 
1936
      Free (Ada_Prj_Path);
1937
 
1938
      --  Copy to Name_Buffer, since we will need to manipulate the path
1939
 
1940
      Name_Len := Self.Path'Length;
1941
      Name_Buffer (1 .. Name_Len) := Self.Path.all;
1942
 
1943
      --  Scan the directory path to see if "-" is one of the directories.
1944
      --  Remove each occurrence of "-" and set Add_Default_Dir to False.
1945
      --  Also resolve relative paths and symbolic links.
1946
 
1947
      First := 3;
1948
      loop
1949
         while First <= Name_Len
1950
           and then (Name_Buffer (First) = Path_Separator)
1951
         loop
1952
            First := First + 1;
1953
         end loop;
1954
 
1955
         exit when First > Name_Len;
1956
 
1957
         Last := First;
1958
 
1959
         while Last < Name_Len
1960
           and then Name_Buffer (Last + 1) /= Path_Separator
1961
         loop
1962
            Last := Last + 1;
1963
         end loop;
1964
 
1965
         --  If the directory is "-", set Add_Default_Dir to False and
1966
         --  remove from path.
1967
 
1968
         if Name_Buffer (First .. Last) = No_Project_Default_Dir then
1969
            Add_Default_Dir := False;
1970
 
1971
            for J in Last + 1 .. Name_Len loop
1972
               Name_Buffer (J - No_Project_Default_Dir'Length - 1) :=
1973
                 Name_Buffer (J);
1974
            end loop;
1975
 
1976
            Name_Len := Name_Len - No_Project_Default_Dir'Length - 1;
1977
 
1978
            --  After removing the '-', go back one character to get the next
1979
            --  directory correctly.
1980
 
1981
            Last := Last - 1;
1982
 
1983
         elsif not Hostparm.OpenVMS
1984
           or else not Is_Absolute_Path (Name_Buffer (First .. Last))
1985
         then
1986
            --  On VMS, only expand relative path names, as absolute paths
1987
            --  may correspond to multi-valued VMS logical names.
1988
 
1989
            declare
1990
               New_Dir : constant String :=
1991
                           Normalize_Pathname
1992
                             (Name_Buffer (First .. Last),
1993
                              Resolve_Links => Opt.Follow_Links_For_Dirs);
1994
 
1995
            begin
1996
               --  If the absolute path was resolved and is different from
1997
               --  the original, replace original with the resolved path.
1998
 
1999
               if New_Dir /= Name_Buffer (First .. Last)
2000
                 and then New_Dir'Length /= 0
2001
               then
2002
                  New_Len := Name_Len + New_Dir'Length - (Last - First + 1);
2003
                  New_Last := First + New_Dir'Length - 1;
2004
                  Name_Buffer (New_Last + 1 .. New_Len) :=
2005
                    Name_Buffer (Last + 1 .. Name_Len);
2006
                  Name_Buffer (First .. New_Last) := New_Dir;
2007
                  Name_Len := New_Len;
2008
                  Last := New_Last;
2009
               end if;
2010
            end;
2011
         end if;
2012
 
2013
         First := Last + 1;
2014
      end loop;
2015
 
2016
      Free (Self.Path);
2017
 
2018
      --  Set the initial value of Current_Project_Path
2019
 
2020
      if Add_Default_Dir then
2021
         declare
2022
            Prefix : String_Ptr;
2023
 
2024
         begin
2025
            if Sdefault.Search_Dir_Prefix = null then
2026
 
2027
               --  gprbuild case
2028
 
2029
               Prefix := new String'(Executable_Prefix_Path);
2030
 
2031
            else
2032
               Prefix := new String'(Sdefault.Search_Dir_Prefix.all
2033
                                     & ".." & Dir_Separator
2034
                                     & ".." & Dir_Separator
2035
                                     & ".." & Dir_Separator
2036
                                     & ".." & Dir_Separator);
2037
            end if;
2038
 
2039
            if Prefix.all /= "" then
2040
               if Target_Name /= "" then
2041
 
2042
                  --  $prefix/$target/lib/gnat
2043
 
2044
                  Add_Str_To_Name_Buffer
2045
                    (Path_Separator & Prefix.all &
2046
                     Target_Name);
2047
 
2048
                  --  Note: Target_Name has a trailing / when it comes from
2049
                  --  Sdefault.
2050
 
2051
                  if Name_Buffer (Name_Len) /= '/' then
2052
                     Add_Char_To_Name_Buffer (Directory_Separator);
2053
                  end if;
2054
 
2055
                  Add_Str_To_Name_Buffer
2056
                    ("lib" & Directory_Separator & "gnat");
2057
               end if;
2058
 
2059
               --  $prefix/share/gpr
2060
 
2061
               Add_Str_To_Name_Buffer
2062
                 (Path_Separator & Prefix.all &
2063
                  "share" & Directory_Separator & "gpr");
2064
 
2065
               --  $prefix/lib/gnat
2066
 
2067
               Add_Str_To_Name_Buffer
2068
                 (Path_Separator & Prefix.all &
2069
                  "lib" & Directory_Separator & "gnat");
2070
            end if;
2071
 
2072
            Free (Prefix);
2073
         end;
2074
      end if;
2075
 
2076
      Self.Path := new String'(Name_Buffer (1 .. Name_Len));
2077
   end Initialize_Default_Project_Path;
2078
 
2079
   --------------
2080
   -- Get_Path --
2081
   --------------
2082
 
2083
   procedure Get_Path (Self : Project_Search_Path; Path : out String_Access) is
2084
   begin
2085
      pragma Assert (Is_Initialized (Self));
2086
      Path := Self.Path;
2087
   end Get_Path;
2088
 
2089
   --------------
2090
   -- Set_Path --
2091
   --------------
2092
 
2093
   procedure Set_Path (Self : in out Project_Search_Path; Path : String) is
2094
   begin
2095
      Free (Self.Path);
2096
      Self.Path := new String'(Path);
2097
      Projects_Paths.Reset (Self.Cache);
2098
   end Set_Path;
2099
 
2100
   -----------------------
2101
   -- Find_Name_In_Path --
2102
   -----------------------
2103
 
2104
   function Find_Name_In_Path
2105
     (Self : Project_Search_Path;
2106
      Path : String) return String_Access
2107
   is
2108
      First  : Natural;
2109
      Last   : Natural;
2110
 
2111
   begin
2112
      if Current_Verbosity = High then
2113
         Debug_Output ("Trying " & Path);
2114
      end if;
2115
 
2116
      if Is_Absolute_Path (Path) then
2117
         if Check_Filename (Path) then
2118
            return new String'(Path);
2119
         else
2120
            return null;
2121
         end if;
2122
 
2123
      else
2124
         --  Because we don't want to resolve symbolic links, we cannot use
2125
         --  Locate_Regular_File. So, we try each possible path successively.
2126
 
2127
         First := Self.Path'First;
2128
         while First <= Self.Path'Last loop
2129
            while First <= Self.Path'Last
2130
              and then Self.Path (First) = Path_Separator
2131
            loop
2132
               First := First + 1;
2133
            end loop;
2134
 
2135
            exit when First > Self.Path'Last;
2136
 
2137
            Last := First;
2138
            while Last < Self.Path'Last
2139
              and then Self.Path (Last + 1) /= Path_Separator
2140
            loop
2141
               Last := Last + 1;
2142
            end loop;
2143
 
2144
            Name_Len := 0;
2145
 
2146
            if not Is_Absolute_Path (Self.Path (First .. Last)) then
2147
               Add_Str_To_Name_Buffer (Get_Current_Dir);  -- ??? System call
2148
               Add_Char_To_Name_Buffer (Directory_Separator);
2149
            end if;
2150
 
2151
            Add_Str_To_Name_Buffer (Self.Path (First .. Last));
2152
            Add_Char_To_Name_Buffer (Directory_Separator);
2153
            Add_Str_To_Name_Buffer (Path);
2154
 
2155
            if Current_Verbosity = High then
2156
               Debug_Output ("Testing file " & Name_Buffer (1 .. Name_Len));
2157
            end if;
2158
 
2159
            if Check_Filename (Name_Buffer (1 .. Name_Len)) then
2160
               return new String'(Name_Buffer (1 .. Name_Len));
2161
            end if;
2162
 
2163
            First := Last + 1;
2164
         end loop;
2165
      end if;
2166
 
2167
      return null;
2168
   end Find_Name_In_Path;
2169
 
2170
   ------------------
2171
   -- Find_Project --
2172
   ------------------
2173
 
2174
   procedure Find_Project
2175
     (Self               : in out Project_Search_Path;
2176
      Project_File_Name  : String;
2177
      Directory          : String;
2178
      Path               : out Namet.Path_Name_Type)
2179
   is
2180
      File : constant String := Project_File_Name;
2181
      --  Have to do a copy, in case the parameter is Name_Buffer, which we
2182
      --  modify below
2183
 
2184
      function Try_Path_Name is new Find_Name_In_Path
2185
        (Check_Filename => Is_Regular_File);
2186
      --  Find a file in the project search path.
2187
 
2188
      --  Local Declarations
2189
 
2190
      Result  : String_Access;
2191
      Has_Dot : Boolean := False;
2192
      Key     : Name_Id;
2193
 
2194
   --  Start of processing for Find_Project
2195
 
2196
   begin
2197
      pragma Assert (Is_Initialized (Self));
2198
 
2199
      if Current_Verbosity = High then
2200
         Debug_Increase_Indent
2201
           ("Searching for project """ & File & """ in """
2202
            & Directory & '"');
2203
      end if;
2204
 
2205
      --  Check the project cache
2206
 
2207
      Name_Len := File'Length;
2208
      Name_Buffer (1 .. Name_Len) := File;
2209
      Key := Name_Find;
2210
      Path := Projects_Paths.Get (Self.Cache, Key);
2211
 
2212
      if Path /= No_Path then
2213
         Debug_Decrease_Indent;
2214
         return;
2215
      end if;
2216
 
2217
      --  Check if File contains an extension (a dot before a
2218
      --  directory separator). If it is the case we do not try project file
2219
      --  with an added extension as it is not possible to have multiple dots
2220
      --  on a project file name.
2221
 
2222
      Check_Dot : for K in reverse File'Range loop
2223
         if File (K) = '.' then
2224
            Has_Dot := True;
2225
            exit Check_Dot;
2226
         end if;
2227
 
2228
         exit Check_Dot when File (K) = Directory_Separator
2229
           or else File (K) = '/';
2230
      end loop Check_Dot;
2231
 
2232
      if not Is_Absolute_Path (File) then
2233
 
2234
         --  First we try <directory>/<file_name>.<extension>
2235
 
2236
         if not Has_Dot then
2237
            Result := Try_Path_Name
2238
              (Self,
2239
               Directory & Directory_Separator &
2240
               File & Project_File_Extension);
2241
         end if;
2242
 
2243
         --  Then we try <directory>/<file_name>
2244
 
2245
         if Result = null then
2246
            Result := Try_Path_Name
2247
                       (Self, Directory & Directory_Separator & File);
2248
         end if;
2249
      end if;
2250
 
2251
      --  Then we try <file_name>.<extension>
2252
 
2253
      if Result = null and then not Has_Dot then
2254
         Result := Try_Path_Name (Self, File & Project_File_Extension);
2255
      end if;
2256
 
2257
      --  Then we try <file_name>
2258
 
2259
      if Result = null then
2260
         Result := Try_Path_Name (Self, File);
2261
      end if;
2262
 
2263
      --  If we cannot find the project file, we return an empty string
2264
 
2265
      if Result = null then
2266
         Path := Namet.No_Path;
2267
         return;
2268
 
2269
      else
2270
         declare
2271
            Final_Result : constant String :=
2272
                             GNAT.OS_Lib.Normalize_Pathname
2273
                               (Result.all,
2274
                                Directory      => Directory,
2275
                                Resolve_Links  => Opt.Follow_Links_For_Files,
2276
                                Case_Sensitive => True);
2277
         begin
2278
            Free (Result);
2279
            Name_Len := Final_Result'Length;
2280
            Name_Buffer (1 .. Name_Len) := Final_Result;
2281
            Path := Name_Find;
2282
            Projects_Paths.Set (Self.Cache, Key, Path);
2283
         end;
2284
      end if;
2285
 
2286
      Debug_Decrease_Indent;
2287
   end Find_Project;
2288
 
2289
   ----------
2290
   -- Free --
2291
   ----------
2292
 
2293
   procedure Free (Self : in out Project_Search_Path) is
2294
   begin
2295
      Free (Self.Path);
2296
      Projects_Paths.Reset (Self.Cache);
2297
   end Free;
2298
 
2299
   ----------
2300
   -- Copy --
2301
   ----------
2302
 
2303
   procedure Copy (From : Project_Search_Path; To : out Project_Search_Path) is
2304
   begin
2305
      Free (To);
2306
 
2307
      if From.Path /= null then
2308
         To.Path := new String'(From.Path.all);
2309
      end if;
2310
 
2311
      --  No need to copy the Cache, it will be recomputed as needed
2312
   end Copy;
2313
 
2314
end Prj.Env;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.