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