projects / gcc.git / blob
? search:


e76a926607f4ded08b8def02ee8dddb6a4a22755
[gcc.git] / gcc / ada / prj-env.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- P R J . E N V --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2001-2009, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 with Fmap;
27 with Opt;
28 with Osint; use Osint;
29 with Output; use Output;
30 with Prj.Com; use Prj.Com;
31 with Tempdir;
32
33 package body Prj.Env is
34
35 Default_Naming : constant Naming_Id := Naming_Table.First;
36
37 -----------------------
38 -- Local Subprograms --
39 -----------------------
40
41 procedure Add_To_Path
42 (Source_Dirs : String_List_Id;
43 In_Tree : Project_Tree_Ref);
44 -- Add to Ada_Path_Buffer all the source directories in string list
45 -- Source_Dirs, if any. Increment Ada_Path_Length.
46
47 procedure Add_To_Path (Dir : String; In_Tree : Project_Tree_Ref);
48 -- If Dir is not already in the global variable Ada_Path_Buffer, add it.
49 -- Increment Ada_Path_Length.
50 -- If Ada_Path_Length /= 0, prepend a Path_Separator character to
51 -- Path.
52
53 procedure Add_To_Source_Path
54 (Source_Dirs : String_List_Id; In_Tree : Project_Tree_Ref);
55 -- Add to Ada_Path_B all the source directories in string list
56 -- Source_Dirs, if any. Increment Ada_Path_Length.
57
58 procedure Add_To_Object_Path
59 (Object_Dir : Path_Name_Type;
60 In_Tree : Project_Tree_Ref);
61 -- Add Object_Dir to object path table. Make sure it is not duplicate
62 -- and it is the last one in the current table.
63
64 procedure Set_Path_File_Var (Name : String; Value : String);
65 -- Call Setenv, after calling To_Host_File_Spec
66
67 function Ultimate_Extension_Of
68 (Project : Project_Id) return Project_Id;
69 -- Return a project that is either Project or an extended ancestor of
70 -- Project that itself is not extended.
71
72 ----------------------
73 -- Ada_Include_Path --
74 ----------------------
75
76 function Ada_Include_Path
77 (Project : Project_Id;
78 In_Tree : Project_Tree_Ref) return String_Access
79 is
80 procedure Add (Project : Project_Id; Dummy : in out Boolean);
81 -- Add source dirs of Project to the path
82
83 ---------
84 -- Add --
85 ---------
86
87 procedure Add (Project : Project_Id; Dummy : in out Boolean) is
88 pragma Unreferenced (Dummy);
89 begin
90 Add_To_Path (Project.Source_Dirs, In_Tree);
91 end Add;
92
93 procedure For_All_Projects is
94 new For_Every_Project_Imported (Boolean, Add);
95 Dummy : Boolean := False;
96
97 -- Start of processing for Ada_Include_Path
98
99 begin
100 -- If it is the first time we call this function for
101 -- this project, compute the source path
102
103 if Project.Ada_Include_Path = null then
104 In_Tree.Private_Part.Ada_Path_Length := 0;
105 For_All_Projects (Project, Dummy);
106
107 Project.Ada_Include_Path :=
108 new String'
109 (In_Tree.Private_Part.Ada_Path_Buffer
110 (1 .. In_Tree.Private_Part.Ada_Path_Length));
111 end if;
112
113 return Project.Ada_Include_Path;
114 end Ada_Include_Path;
115
116 ----------------------
117 -- Ada_Include_Path --
118 ----------------------
119
120 function Ada_Include_Path
121 (Project : Project_Id;
122 In_Tree : Project_Tree_Ref;
123 Recursive : Boolean) return String
124 is
125 begin
126 if Recursive then
127 return Ada_Include_Path (Project, In_Tree).all;
128 else
129 In_Tree.Private_Part.Ada_Path_Length := 0;
130 Add_To_Path (Project.Source_Dirs, In_Tree);
131 return
132 In_Tree.Private_Part.Ada_Path_Buffer
133 (1 .. In_Tree.Private_Part.Ada_Path_Length);
134 end if;
135 end Ada_Include_Path;
136
137 ----------------------
138 -- Ada_Objects_Path --
139 ----------------------
140
141 function Ada_Objects_Path
142 (Project : Project_Id;
143 In_Tree : Project_Tree_Ref;
144 Including_Libraries : Boolean := True) return String_Access
145 is
146 procedure Add (Project : Project_Id; Dummy : in out Boolean);
147 -- Add all the object directories of a project to the path
148
149 ---------
150 -- Add --
151 ---------
152
153 procedure Add (Project : Project_Id; Dummy : in out Boolean) is
154 pragma Unreferenced (Dummy);
155 Path : constant Path_Name_Type :=
156 Get_Object_Directory
157 (Project,
158 Including_Libraries => Including_Libraries,
159 Only_If_Ada => False);
160 begin
161 if Path /= No_Path then
162 Add_To_Path (Get_Name_String (Path), In_Tree);
163 end if;
164 end Add;
165
166 procedure For_All_Projects is
167 new For_Every_Project_Imported (Boolean, Add);
168 Dummy : Boolean := False;
169
170 -- Start of processing for Ada_Objects_Path
171
172 begin
173 -- If it is the first time we call this function for
174 -- this project, compute the objects path
175
176 if Project.Ada_Objects_Path = null then
177 In_Tree.Private_Part.Ada_Path_Length := 0;
178 For_All_Projects (Project, Dummy);
179
180 Project.Ada_Objects_Path :=
181 new String'
182 (In_Tree.Private_Part.Ada_Path_Buffer
183 (1 .. In_Tree.Private_Part.Ada_Path_Length));
184 end if;
185
186 return Project.Ada_Objects_Path;
187 end Ada_Objects_Path;
188
189 ------------------------
190 -- Add_To_Object_Path --
191 ------------------------
192
193 procedure Add_To_Object_Path
194 (Object_Dir : Path_Name_Type; In_Tree : Project_Tree_Ref)
195 is
196 begin
197 -- Check if the directory is already in the table
198
199 for Index in Object_Path_Table.First ..
200 Object_Path_Table.Last (In_Tree.Private_Part.Object_Paths)
201 loop
202
203 -- If it is, remove it, and add it as the last one
204
205 if In_Tree.Private_Part.Object_Paths.Table (Index) = Object_Dir then
206 for Index2 in Index + 1 ..
207 Object_Path_Table.Last
208 (In_Tree.Private_Part.Object_Paths)
209 loop
210 In_Tree.Private_Part.Object_Paths.Table (Index2 - 1) :=
211 In_Tree.Private_Part.Object_Paths.Table (Index2);
212 end loop;
213
214 In_Tree.Private_Part.Object_Paths.Table
215 (Object_Path_Table.Last (In_Tree.Private_Part.Object_Paths)) :=
216 Object_Dir;
217 return;
218 end if;
219 end loop;
220
221 -- The directory is not already in the table, add it
222
223 Object_Path_Table.Increment_Last (In_Tree.Private_Part.Object_Paths);
224 In_Tree.Private_Part.Object_Paths.Table
225 (Object_Path_Table.Last (In_Tree.Private_Part.Object_Paths)) :=
226 Object_Dir;
227 end Add_To_Object_Path;
228
229 -----------------
230 -- Add_To_Path --
231 -----------------
232
233 procedure Add_To_Path
234 (Source_Dirs : String_List_Id;
235 In_Tree : Project_Tree_Ref)
236 is
237 Current : String_List_Id := Source_Dirs;
238 Source_Dir : String_Element;
239 begin
240 while Current /= Nil_String loop
241 Source_Dir := In_Tree.String_Elements.Table (Current);
242 Add_To_Path (Get_Name_String (Source_Dir.Display_Value), In_Tree);
243 Current := Source_Dir.Next;
244 end loop;
245 end Add_To_Path;
246
247 procedure Add_To_Path (Dir : String; In_Tree : Project_Tree_Ref) is
248 Len : Natural;
249 New_Buffer : String_Access;
250 Min_Len : Natural;
251
252 function Is_Present (Path : String; Dir : String) return Boolean;
253 -- Return True if Dir is part of Path
254
255 ----------------
256 -- Is_Present --
257 ----------------
258
259 function Is_Present (Path : String; Dir : String) return Boolean is
260 Last : constant Integer := Path'Last - Dir'Length + 1;
261
262 begin
263 for J in Path'First .. Last loop
264
265 -- Note: the order of the conditions below is important, since
266 -- it ensures a minimal number of string comparisons.
267
268 if (J = Path'First
269 or else Path (J - 1) = Path_Separator)
270 and then
271 (J + Dir'Length > Path'Last
272 or else Path (J + Dir'Length) = Path_Separator)
273 and then Dir = Path (J .. J + Dir'Length - 1)
274 then
275 return True;
276 end if;
277 end loop;
278
279 return False;
280 end Is_Present;
281
282 -- Start of processing for Add_To_Path
283
284 begin
285 if Is_Present (In_Tree.Private_Part.Ada_Path_Buffer
286 (1 .. In_Tree.Private_Part.Ada_Path_Length),
287 Dir)
288 then
289
290 -- Dir is already in the path, nothing to do
291
292 return;
293 end if;
294
295 Min_Len := In_Tree.Private_Part.Ada_Path_Length + Dir'Length;
296
297 if In_Tree.Private_Part.Ada_Path_Length > 0 then
298
299 -- Add 1 for the Path_Separator character
300
301 Min_Len := Min_Len + 1;
302 end if;
303
304 -- If Ada_Path_Buffer is too small, increase it
305
306 Len := In_Tree.Private_Part.Ada_Path_Buffer'Last;
307
308 if Len < Min_Len then
309 loop
310 Len := Len * 2;
311 exit when Len >= Min_Len;
312 end loop;
313
314 New_Buffer := new String (1 .. Len);
315 New_Buffer (1 .. In_Tree.Private_Part.Ada_Path_Length) :=
316 In_Tree.Private_Part.Ada_Path_Buffer
317 (1 .. In_Tree.Private_Part.Ada_Path_Length);
318 Free (In_Tree.Private_Part.Ada_Path_Buffer);
319 In_Tree.Private_Part.Ada_Path_Buffer := New_Buffer;
320 end if;
321
322 if In_Tree.Private_Part.Ada_Path_Length > 0 then
323 In_Tree.Private_Part.Ada_Path_Length :=
324 In_Tree.Private_Part.Ada_Path_Length + 1;
325 In_Tree.Private_Part.Ada_Path_Buffer
326 (In_Tree.Private_Part.Ada_Path_Length) := Path_Separator;
327 end if;
328
329 In_Tree.Private_Part.Ada_Path_Buffer
330 (In_Tree.Private_Part.Ada_Path_Length + 1 ..
331 In_Tree.Private_Part.Ada_Path_Length + Dir'Length) := Dir;
332 In_Tree.Private_Part.Ada_Path_Length :=
333 In_Tree.Private_Part.Ada_Path_Length + Dir'Length;
334 end Add_To_Path;
335
336 ------------------------
337 -- Add_To_Source_Path --
338 ------------------------
339
340 procedure Add_To_Source_Path
341 (Source_Dirs : String_List_Id; In_Tree : Project_Tree_Ref)
342 is
343 Current : String_List_Id := Source_Dirs;
344 Source_Dir : String_Element;
345 Add_It : Boolean;
346
347 begin
348 -- Add each source directory
349
350 while Current /= Nil_String loop
351 Source_Dir := In_Tree.String_Elements.Table (Current);
352 Add_It := True;
353
354 -- Check if the source directory is already in the table
355
356 for Index in Source_Path_Table.First ..
357 Source_Path_Table.Last
358 (In_Tree.Private_Part.Source_Paths)
359 loop
360 -- If it is already, no need to add it
361
362 if In_Tree.Private_Part.Source_Paths.Table (Index) =
363 Source_Dir.Value
364 then
365 Add_It := False;
366 exit;
367 end if;
368 end loop;
369
370 if Add_It then
371 Source_Path_Table.Increment_Last
372 (In_Tree.Private_Part.Source_Paths);
373 In_Tree.Private_Part.Source_Paths.Table
374 (Source_Path_Table.Last (In_Tree.Private_Part.Source_Paths)) :=
375 Source_Dir.Value;
376 end if;
377
378 -- Next source directory
379
380 Current := Source_Dir.Next;
381 end loop;
382 end Add_To_Source_Path;
383
384 --------------------------------
385 -- Create_Config_Pragmas_File --
386 --------------------------------
387
388 procedure Create_Config_Pragmas_File
389 (For_Project : Project_Id;
390 Main_Project : Project_Id;
391 In_Tree : Project_Tree_Ref;
392 Include_Config_Files : Boolean := True)
393 is
394 pragma Unreferenced (Main_Project);
395 pragma Unreferenced (Include_Config_Files);
396
397 File_Name : Path_Name_Type := No_Path;
398 File : File_Descriptor := Invalid_FD;
399
400 Current_Unit : Unit_Index := Units_Htable.Get_First (In_Tree.Units_HT);
401
402 First_Project : Project_List;
403
404 Current_Project : Project_List;
405 Current_Naming : Naming_Id;
406
407 Status : Boolean;
408 -- For call to Close
409
410 procedure Check (Project : Project_Id);
411 -- Recursive procedure that put in the config pragmas file any non
412 -- standard naming schemes, if it is not already in the file, then call
413 -- itself for any imported project.
414
415 procedure Check_Temp_File;
416 -- Check that a temporary file has been opened.
417 -- If not, create one, and put its name in the project data,
418 -- with the indication that it is a temporary file.
419
420 procedure Put
421 (Unit_Name : Name_Id;
422 File_Name : File_Name_Type;
423 Unit_Kind : Spec_Or_Body;
424 Index : Int);
425 -- Put an SFN pragma in the temporary file
426
427 procedure Put (File : File_Descriptor; S : String);
428 procedure Put_Line (File : File_Descriptor; S : String);
429 -- Output procedures, analogous to normal Text_IO procs of same name
430
431 -----------
432 -- Check --
433 -----------
434
435 procedure Check (Project : Project_Id) is
436 begin
437 if Current_Verbosity = High then
438 Write_Str ("Checking project file """);
439 Write_Str (Namet.Get_Name_String (Project.Name));
440 Write_Str (""".");
441 Write_Eol;
442 end if;
443
444 -- Is this project in the list of the visited project?
445
446 Current_Project := First_Project;
447 while Current_Project /= null
448 and then Current_Project.Project /= Project
449 loop
450 Current_Project := Current_Project.Next;
451 end loop;
452
453 -- If it is not, put it in the list, and visit it
454
455 if Current_Project = null then
456 First_Project := new Project_List_Element'
457 (Project => Project,
458 Next => First_Project);
459
460 -- Is the naming scheme of this project one that we know?
461
462 Current_Naming := Default_Naming;
463 while Current_Naming <=
464 Naming_Table.Last (In_Tree.Private_Part.Namings)
465 and then not Same_Naming_Scheme
466 (Left => In_Tree.Private_Part.Namings.Table (Current_Naming),
467 Right => Project.Naming) loop
468 Current_Naming := Current_Naming + 1;
469 end loop;
470
471 -- If we don't know it, add it
472
473 if Current_Naming >
474 Naming_Table.Last (In_Tree.Private_Part.Namings)
475 then
476 Naming_Table.Increment_Last (In_Tree.Private_Part.Namings);
477 In_Tree.Private_Part.Namings.Table
478 (Naming_Table.Last (In_Tree.Private_Part.Namings)) :=
479 Project.Naming;
480
481 -- We need a temporary file to be created
482
483 Check_Temp_File;
484
485 -- Put the SFN pragmas for the naming scheme
486
487 -- Spec
488
489 Put_Line
490 (File, "pragma Source_File_Name_Project");
491 Put_Line
492 (File, " (Spec_File_Name => ""*" &
493 Spec_Suffix_Of (In_Tree, "ada", Project.Naming) &
494 """,");
495 Put_Line
496 (File, " Casing => " &
497 Image (Project.Naming.Casing) & ",");
498 Put_Line
499 (File, " Dot_Replacement => """ &
500 Namet.Get_Name_String (Project.Naming.Dot_Replacement) &
501 """);");
502
503 -- and body
504
505 Put_Line
506 (File, "pragma Source_File_Name_Project");
507 Put_Line
508 (File, " (Body_File_Name => ""*" &
509 Body_Suffix_Of (In_Tree, "ada", Project.Naming) &
510 """,");
511 Put_Line
512 (File, " Casing => " &
513 Image (Project.Naming.Casing) & ",");
514 Put_Line
515 (File, " Dot_Replacement => """ &
516 Namet.Get_Name_String (Project.Naming.Dot_Replacement) &
517 """);");
518
519 -- and maybe separate
520
521 if Body_Suffix_Of (In_Tree, "ada", Project.Naming) /=
522 Get_Name_String (Project.Naming.Separate_Suffix)
523 then
524 Put_Line
525 (File, "pragma Source_File_Name_Project");
526 Put_Line
527 (File, " (Subunit_File_Name => ""*" &
528 Namet.Get_Name_String (Project.Naming.Separate_Suffix) &
529 """,");
530 Put_Line
531 (File, " Casing => " &
532 Image (Project.Naming.Casing) &
533 ",");
534 Put_Line
535 (File, " Dot_Replacement => """ &
536 Namet.Get_Name_String (Project.Naming.Dot_Replacement) &
537 """);");
538 end if;
539 end if;
540
541 if Project.Extends /= No_Project then
542 Check (Project.Extends);
543 end if;
544
545 declare
546 Current : Project_List := Project.Imported_Projects;
547 begin
548 while Current /= null loop
549 Check (Current.Project);
550 Current := Current.Next;
551 end loop;
552 end;
553 end if;
554 end Check;
555
556 ---------------------
557 -- Check_Temp_File --
558 ---------------------
559
560 procedure Check_Temp_File is
561 begin
562 if File = Invalid_FD then
563 Tempdir.Create_Temp_File (File, Name => File_Name);
564
565 if File = Invalid_FD then
566 Prj.Com.Fail
567 ("unable to create temporary configuration pragmas file");
568
569 else
570 Record_Temp_File (File_Name);
571
572 if Opt.Verbose_Mode then
573 Write_Str ("Creating temp file """);
574 Write_Str (Get_Name_String (File_Name));
575 Write_Line ("""");
576 end if;
577 end if;
578 end if;
579 end Check_Temp_File;
580
581 ---------
582 -- Put --
583 ---------
584
585 procedure Put
586 (Unit_Name : Name_Id;
587 File_Name : File_Name_Type;
588 Unit_Kind : Spec_Or_Body;
589 Index : Int)
590 is
591 begin
592 -- A temporary file needs to be open
593
594 Check_Temp_File;
595
596 -- Put the pragma SFN for the unit kind (spec or body)
597
598 Put (File, "pragma Source_File_Name_Project (");
599 Put (File, Namet.Get_Name_String (Unit_Name));
600
601 if Unit_Kind = Spec then
602 Put (File, ", Spec_File_Name => """);
603 else
604 Put (File, ", Body_File_Name => """);
605 end if;
606
607 Put (File, Namet.Get_Name_String (File_Name));
608 Put (File, """");
609
610 if Index /= 0 then
611 Put (File, ", Index =>");
612 Put (File, Index'Img);
613 end if;
614
615 Put_Line (File, ");");
616 end Put;
617
618 procedure Put (File : File_Descriptor; S : String) is
619 Last : Natural;
620
621 begin
622 Last := Write (File, S (S'First)'Address, S'Length);
623
624 if Last /= S'Length then
625 Prj.Com.Fail ("Disk full");
626 end if;
627
628 if Current_Verbosity = High then
629 Write_Str (S);
630 end if;
631 end Put;
632
633 --------------
634 -- Put_Line --
635 --------------
636
637 procedure Put_Line (File : File_Descriptor; S : String) is
638 S0 : String (1 .. S'Length + 1);
639 Last : Natural;
640
641 begin
642 -- Add an ASCII.LF to the string. As this config file is supposed to
643 -- be used only by the compiler, we don't care about the characters
644 -- for the end of line. In fact we could have put a space, but
645 -- it is more convenient to be able to read gnat.adc during
646 -- development, for which the ASCII.LF is fine.
647
648 S0 (1 .. S'Length) := S;
649 S0 (S0'Last) := ASCII.LF;
650 Last := Write (File, S0'Address, S0'Length);
651
652 if Last /= S'Length + 1 then
653 Prj.Com.Fail ("Disk full");
654 end if;
655
656 if Current_Verbosity = High then
657 Write_Line (S);
658 end if;
659 end Put_Line;
660
661 -- Start of processing for Create_Config_Pragmas_File
662
663 begin
664 if not For_Project.Config_Checked then
665
666 -- Remove any memory of processed naming schemes, if any
667
668 Naming_Table.Set_Last (In_Tree.Private_Part.Namings, Default_Naming);
669
670 -- Check the naming schemes
671
672 Check (For_Project);
673
674 -- Visit all the units and process those that need an SFN pragma
675
676 while Current_Unit /= No_Unit_Index loop
677 if Current_Unit.File_Names (Spec) /= null
678 and then Current_Unit.File_Names (Spec).Naming_Exception
679 then
680 Put (Current_Unit.Name,
681 Current_Unit.File_Names (Spec).File,
682 Spec,
683 Current_Unit.File_Names (Spec).Index);
684 end if;
685
686 if Current_Unit.File_Names (Impl) /= null
687 and then Current_Unit.File_Names (Impl).Naming_Exception
688 then
689 Put (Current_Unit.Name,
690 Current_Unit.File_Names (Impl).File,
691 Impl,
692 Current_Unit.File_Names (Impl).Index);
693 end if;
694
695 Current_Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
696 end loop;
697
698 -- If there are no non standard naming scheme, issue the GNAT
699 -- standard naming scheme. This will tell the compiler that
700 -- a project file is used and will forbid any pragma SFN.
701
702 if File = Invalid_FD then
703 Check_Temp_File;
704
705 Put_Line (File, "pragma Source_File_Name_Project");
706 Put_Line (File, " (Spec_File_Name => ""*.ads"",");
707 Put_Line (File, " Dot_Replacement => ""-"",");
708 Put_Line (File, " Casing => lowercase);");
709
710 Put_Line (File, "pragma Source_File_Name_Project");
711 Put_Line (File, " (Body_File_Name => ""*.adb"",");
712 Put_Line (File, " Dot_Replacement => ""-"",");
713 Put_Line (File, " Casing => lowercase);");
714 end if;
715
716 -- Close the temporary file
717
718 GNAT.OS_Lib.Close (File, Status);
719
720 if not Status then
721 Prj.Com.Fail ("disk full");
722 end if;
723
724 if Opt.Verbose_Mode then
725 Write_Str ("Closing configuration file """);
726 Write_Str (Get_Name_String (File_Name));
727 Write_Line ("""");
728 end if;
729
730 For_Project.Config_File_Name := File_Name;
731 For_Project.Config_File_Temp := True;
732 For_Project.Config_Checked := True;
733 end if;
734 end Create_Config_Pragmas_File;
735
736 --------------------
737 -- Create_Mapping --
738 --------------------
739
740 procedure Create_Mapping (In_Tree : Project_Tree_Ref) is
741 Unit : Unit_Index;
742 Data : Source_Id;
743
744 begin
745 Fmap.Reset_Tables;
746
747 Unit := Units_Htable.Get_First (In_Tree.Units_HT);
748 while Unit /= No_Unit_Index loop
749
750 -- Process only if the unit has a valid name
751
752 if Unit.Name /= No_Name then
753 Data := Unit.File_Names (Spec);
754
755 -- If there is a spec put it in the mapping
756
757 if Data /= null then
758 if Data.Path.Name = Slash then
759 Fmap.Add_Forbidden_File_Name (Data.File);
760 else
761 Fmap.Add_To_File_Map
762 (Unit_Name => Unit_Name_Type (Unit.Name),
763 File_Name => Data.File,
764 Path_Name => File_Name_Type (Data.Path.Name));
765 end if;
766 end if;
767
768 Data := Unit.File_Names (Impl);
769
770 -- If there is a body (or subunit) put it in the mapping
771
772 if Data /= null then
773 if Data.Path.Name = Slash then
774 Fmap.Add_Forbidden_File_Name (Data.File);
775 else
776 Fmap.Add_To_File_Map
777 (Unit_Name => Unit_Name_Type (Unit.Name),
778 File_Name => Data.File,
779 Path_Name => File_Name_Type (Data.Path.Name));
780 end if;
781 end if;
782 end if;
783
784 Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
785 end loop;
786 end Create_Mapping;
787
788 -------------------------
789 -- Create_Mapping_File --
790 -------------------------
791
792 procedure Create_Mapping_File
793 (Project : Project_Id;
794 Language : Name_Id := No_Name;
795 In_Tree : Project_Tree_Ref;
796 Name : out Path_Name_Type)
797 is
798 File : File_Descriptor := Invalid_FD;
799 Status : Boolean;
800
801 Present : Project_Boolean_Htable.Instance;
802 -- For each project in the closure of Project, the corresponding flag
803 -- will be set to True.
804
805 Source : Source_Id;
806 Suffix : File_Name_Type;
807 Unit : Unit_Index;
808 Data : Source_Id;
809 Iter : Source_Iterator;
810
811 procedure Put_Name_Buffer;
812 -- Put the line contained in the Name_Buffer in the mapping file
813
814 procedure Put_Data (Spec : Boolean);
815 -- Put the mapping of the spec or body contained in Data in the file
816 -- (3 lines).
817
818 procedure Recursive_Flag (Prj : Project_Id);
819 -- Set the flags corresponding to Prj, the projects it imports
820 -- (directly or indirectly) or extends to True. Call itself recursively.
821
822 ---------
823 -- Put --
824 ---------
825
826 procedure Put_Name_Buffer is
827 Last : Natural;
828
829 begin
830 Name_Len := Name_Len + 1;
831 Name_Buffer (Name_Len) := ASCII.LF;
832 Last := Write (File, Name_Buffer (1)'Address, Name_Len);
833
834 if Last /= Name_Len then
835 Prj.Com.Fail ("Disk full, cannot write mapping file");
836 end if;
837 end Put_Name_Buffer;
838
839 --------------
840 -- Put_Data --
841 --------------
842
843 procedure Put_Data (Spec : Boolean) is
844 begin
845 -- Line with the unit name
846
847 Get_Name_String (Unit.Name);
848 Name_Len := Name_Len + 1;
849 Name_Buffer (Name_Len) := '%';
850 Name_Len := Name_Len + 1;
851
852 if Spec then
853 Name_Buffer (Name_Len) := 's';
854 else
855 Name_Buffer (Name_Len) := 'b';
856 end if;
857
858 Put_Name_Buffer;
859
860 -- Line with the file name
861
862 Get_Name_String (Data.File);
863 Put_Name_Buffer;
864
865 -- Line with the path name
866
867 Get_Name_String (Data.Path.Name);
868 Put_Name_Buffer;
869 end Put_Data;
870
871 --------------------
872 -- Recursive_Flag --
873 --------------------
874
875 procedure Recursive_Flag (Prj : Project_Id) is
876 Imported : Project_List;
877
878 begin
879 -- Nothing to do for non existent project or project that has already
880 -- been flagged.
881
882 if Prj /= No_Project
883 and then not Project_Boolean_Htable.Get (Present, Prj)
884 then
885 Project_Boolean_Htable.Set (Present, Prj, True);
886
887 Imported := Prj.Imported_Projects;
888 while Imported /= null loop
889 Recursive_Flag (Imported.Project);
890 Imported := Imported.Next;
891 end loop;
892
893 Recursive_Flag (Prj.Extends);
894 end if;
895 end Recursive_Flag;
896
897 -- Start of processing for Create_Mapping_File
898
899 begin
900 -- Flag the necessary projects
901
902 Recursive_Flag (Project);
903
904 -- Create the temporary file
905
906 Tempdir.Create_Temp_File (File, Name => Name);
907
908 if File = Invalid_FD then
909 Prj.Com.Fail ("unable to create temporary mapping file");
910
911 else
912 Record_Temp_File (Name);
913
914 if Opt.Verbose_Mode then
915 Write_Str ("Creating temp mapping file """);
916 Write_Str (Get_Name_String (Name));
917 Write_Line ("""");
918 end if;
919 end if;
920
921 if Language = No_Name then
922 if In_Tree.Private_Part.Fill_Mapping_File then
923 Unit := Units_Htable.Get_First (In_Tree.Units_HT);
924 while Unit /= null loop
925 -- Case of unit has a valid name
926
927 if Unit.Name /= No_Name then
928 Data := Unit.File_Names (Spec);
929
930 -- If there is a spec, put it mapping in the file if it is
931 -- from a project in the closure of Project.
932
933 if Data /= No_Source
934 and then Project_Boolean_Htable.Get (Present, Data.Project)
935 then
936 Put_Data (Spec => True);
937 end if;
938
939 Data := Unit.File_Names (Impl);
940
941 -- If there is a body (or subunit) put its mapping in the
942 -- file if it is from a project in the closure of Project.
943
944 if Data /= No_Source
945 and then Project_Boolean_Htable.Get (Present, Data.Project)
946 then
947 Put_Data (Spec => False);
948 end if;
949 end if;
950
951 Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
952 end loop;
953 end if;
954
955 -- If language is defined
956
957 else
958 -- For all source of the Language of all projects in the closure
959
960 declare
961 P : Project_List;
962
963 begin
964 P := In_Tree.Projects;
965 while P /= null loop
966 if Project_Boolean_Htable.Get (Present, P.Project) then
967
968 Iter := For_Each_Source (In_Tree, P.Project);
969 loop
970 Source := Prj.Element (Iter);
971 exit when Source = No_Source;
972
973 if Source.Language.Name = Language
974 and then not Source.Locally_Removed
975 and then Source.Replaced_By = No_Source
976 and then Source.Path.Name /= No_Path
977 then
978 if Source.Unit /= No_Unit_Index then
979 Get_Name_String (Source.Unit.Name);
980
981 if Source.Kind = Spec then
982 Suffix :=
983 Source.Language.Config.Mapping_Spec_Suffix;
984 else
985 Suffix :=
986 Source.Language.Config.Mapping_Body_Suffix;
987 end if;
988
989 if Suffix /= No_File then
990 Add_Str_To_Name_Buffer
991 (Get_Name_String (Suffix));
992 end if;
993
994 Put_Name_Buffer;
995 end if;
996
997 Get_Name_String (Source.File);
998 Put_Name_Buffer;
999
1000 Get_Name_String (Source.Path.Name);
1001 Put_Name_Buffer;
1002 end if;
1003
1004 Next (Iter);
1005 end loop;
1006 end if;
1007
1008 P := P.Next;
1009 end loop;
1010 end;
1011 end if;
1012
1013 GNAT.OS_Lib.Close (File, Status);
1014
1015 if not Status then
1016
1017 -- We were able to create the temporary file, so there is no problem
1018 -- of protection. However, we are not able to close it, so there must
1019 -- be a capacity problem that we express using "disk full".
1020
1021 Prj.Com.Fail ("disk full, could not write mapping file");
1022 end if;
1023
1024 Project_Boolean_Htable.Reset (Present);
1025 end Create_Mapping_File;
1026
1027 --------------------------
1028 -- Create_New_Path_File --
1029 --------------------------
1030
1031 procedure Create_New_Path_File
1032 (In_Tree : Project_Tree_Ref;
1033 Path_FD : out File_Descriptor;
1034 Path_Name : out Path_Name_Type)
1035 is
1036 begin
1037 Tempdir.Create_Temp_File (Path_FD, Path_Name);
1038
1039 if Path_Name /= No_Path then
1040 Record_Temp_File (Path_Name);
1041
1042 -- Record the name, so that the temp path file will be deleted at the
1043 -- end of the program.
1044
1045 Path_File_Table.Increment_Last (In_Tree.Private_Part.Path_Files);
1046 In_Tree.Private_Part.Path_Files.Table
1047 (Path_File_Table.Last (In_Tree.Private_Part.Path_Files)) :=
1048 Path_Name;
1049 end if;
1050 end Create_New_Path_File;
1051
1052 ---------------------------
1053 -- Delete_All_Path_Files --
1054 ---------------------------
1055
1056 procedure Delete_All_Path_Files (In_Tree : Project_Tree_Ref) is
1057 Disregard : Boolean := True;
1058 pragma Unreferenced (Disregard);
1059
1060 begin
1061 for Index in Path_File_Table.First ..
1062 Path_File_Table.Last (In_Tree.Private_Part.Path_Files)
1063 loop
1064 if In_Tree.Private_Part.Path_Files.Table (Index) /= No_Path then
1065 Delete_File
1066 (Get_Name_String
1067 (In_Tree.Private_Part.Path_Files.Table (Index)),
1068 Disregard);
1069 end if;
1070 end loop;
1071
1072 -- If any of the environment variables ADA_PRJ_INCLUDE_FILE or
1073 -- ADA_PRJ_OBJECTS_FILE has been set, then reset their value to
1074 -- the empty string. On VMS, this has the effect of deassigning
1075 -- the logical names.
1076
1077 if In_Tree.Private_Part.Ada_Prj_Include_File_Set then
1078 Setenv (Project_Include_Path_File, "");
1079 In_Tree.Private_Part.Ada_Prj_Include_File_Set := False;
1080 end if;
1081
1082 if In_Tree.Private_Part.Ada_Prj_Objects_File_Set then
1083 Setenv (Project_Objects_Path_File, "");
1084 In_Tree.Private_Part.Ada_Prj_Objects_File_Set := False;
1085 end if;
1086 end Delete_All_Path_Files;
1087
1088 ------------------------------------
1089 -- File_Name_Of_Library_Unit_Body --
1090 ------------------------------------
1091
1092 function File_Name_Of_Library_Unit_Body
1093 (Name : String;
1094 Project : Project_Id;
1095 In_Tree : Project_Tree_Ref;
1096 Main_Project_Only : Boolean := True;
1097 Full_Path : Boolean := False) return String
1098 is
1099 The_Project : Project_Id := Project;
1100 Original_Name : String := Name;
1101
1102 Extended_Spec_Name : String :=
1103 Name &
1104 Spec_Suffix_Of (In_Tree, "ada", Project.Naming);
1105 Extended_Body_Name : String :=
1106 Name &
1107 Body_Suffix_Of (In_Tree, "ada", Project.Naming);
1108
1109 Unit : Unit_Index;
1110 The_Original_Name : Name_Id;
1111 The_Spec_Name : Name_Id;
1112 The_Body_Name : Name_Id;
1113
1114 begin
1115 Canonical_Case_File_Name (Original_Name);
1116 Name_Len := Original_Name'Length;
1117 Name_Buffer (1 .. Name_Len) := Original_Name;
1118 The_Original_Name := Name_Find;
1119
1120 Canonical_Case_File_Name (Extended_Spec_Name);
1121 Name_Len := Extended_Spec_Name'Length;
1122 Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
1123 The_Spec_Name := Name_Find;
1124
1125 Canonical_Case_File_Name (Extended_Body_Name);
1126 Name_Len := Extended_Body_Name'Length;
1127 Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
1128 The_Body_Name := Name_Find;
1129
1130 if Current_Verbosity = High then
1131 Write_Str ("Looking for file name of """);
1132 Write_Str (Name);
1133 Write_Char ('"');
1134 Write_Eol;
1135 Write_Str (" Extended Spec Name = """);
1136 Write_Str (Extended_Spec_Name);
1137 Write_Char ('"');
1138 Write_Eol;
1139 Write_Str (" Extended Body Name = """);
1140 Write_Str (Extended_Body_Name);
1141 Write_Char ('"');
1142 Write_Eol;
1143 end if;
1144
1145 -- For extending project, search in the extended project if the source
1146 -- is not found. For non extending projects, this loop will be run only
1147 -- once.
1148
1149 loop
1150 -- Loop through units
1151
1152 Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1153 while Unit /= null loop
1154 -- Check for body
1155
1156 if not Main_Project_Only
1157 or else
1158 (Unit.File_Names (Impl) /= null
1159 and then Unit.File_Names (Impl).Project = The_Project)
1160 then
1161 declare
1162 Current_Name : File_Name_Type;
1163 begin
1164 -- Case of a body present
1165
1166 if Unit.File_Names (Impl) /= null then
1167 Current_Name := Unit.File_Names (Impl).File;
1168
1169 if Current_Verbosity = High then
1170 Write_Str (" Comparing with """);
1171 Write_Str (Get_Name_String (Current_Name));
1172 Write_Char ('"');
1173 Write_Eol;
1174 end if;
1175
1176 -- If it has the name of the original name, return the
1177 -- original name.
1178
1179 if Unit.Name = The_Original_Name
1180 or else
1181 Current_Name = File_Name_Type (The_Original_Name)
1182 then
1183 if Current_Verbosity = High then
1184 Write_Line (" OK");
1185 end if;
1186
1187 if Full_Path then
1188 return Get_Name_String
1189 (Unit.File_Names (Impl).Path.Name);
1190
1191 else
1192 return Get_Name_String (Current_Name);
1193 end if;
1194
1195 -- If it has the name of the extended body name,
1196 -- return the extended body name
1197
1198 elsif Current_Name = File_Name_Type (The_Body_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 (Impl).Path.Name);
1206
1207 else
1208 return Extended_Body_Name;
1209 end if;
1210
1211 else
1212 if Current_Verbosity = High then
1213 Write_Line (" not good");
1214 end if;
1215 end if;
1216 end if;
1217 end;
1218 end if;
1219
1220 -- Check for spec
1221
1222 if not Main_Project_Only
1223 or else
1224 (Unit.File_Names (Spec) /= null
1225 and then Unit.File_Names (Spec).Project =
1226 The_Project)
1227 then
1228 declare
1229 Current_Name : File_Name_Type;
1230
1231 begin
1232 -- Case of spec present
1233
1234 if Unit.File_Names (Spec) /= null then
1235 Current_Name := Unit.File_Names (Spec).File;
1236 if Current_Verbosity = High then
1237 Write_Str (" Comparing with """);
1238 Write_Str (Get_Name_String (Current_Name));
1239 Write_Char ('"');
1240 Write_Eol;
1241 end if;
1242
1243 -- If name same as original name, return original name
1244
1245 if Unit.Name = The_Original_Name
1246 or else
1247 Current_Name = File_Name_Type (The_Original_Name)
1248 then
1249 if Current_Verbosity = High then
1250 Write_Line (" OK");
1251 end if;
1252
1253 if Full_Path then
1254 return Get_Name_String
1255 (Unit.File_Names (Spec).Path.Name);
1256 else
1257 return Get_Name_String (Current_Name);
1258 end if;
1259
1260 -- If it has the same name as the extended spec name,
1261 -- return the extended spec name.
1262
1263 elsif Current_Name = File_Name_Type (The_Spec_Name) then
1264 if Current_Verbosity = High then
1265 Write_Line (" OK");
1266 end if;
1267
1268 if Full_Path then
1269 return Get_Name_String
1270 (Unit.File_Names (Spec).Path.Name);
1271 else
1272 return Extended_Spec_Name;
1273 end if;
1274
1275 else
1276 if Current_Verbosity = High then
1277 Write_Line (" not good");
1278 end if;
1279 end if;
1280 end if;
1281 end;
1282 end if;
1283
1284 Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1285 end loop;
1286
1287 -- If we are not in an extending project, give up
1288
1289 exit when not Main_Project_Only
1290 or else The_Project.Extends = No_Project;
1291
1292 -- Otherwise, look in the project we are extending
1293
1294 The_Project := The_Project.Extends;
1295 end loop;
1296
1297 -- We don't know this file name, return an empty string
1298
1299 return "";
1300 end File_Name_Of_Library_Unit_Body;
1301
1302 -------------------------
1303 -- For_All_Object_Dirs --
1304 -------------------------
1305
1306 procedure For_All_Object_Dirs (Project : Project_Id) is
1307 procedure For_Project (Prj : Project_Id; Dummy : in out Integer);
1308 -- Get all object directories of Prj
1309
1310 -----------------
1311 -- For_Project --
1312 -----------------
1313
1314 procedure For_Project (Prj : Project_Id; Dummy : in out Integer) is
1315 pragma Unreferenced (Dummy);
1316 begin
1317 -- ??? Set_Ada_Paths has a different behavior for library project
1318 -- files, should we have the same ?
1319
1320 if Prj.Object_Directory /= No_Path_Information then
1321 Get_Name_String (Prj.Object_Directory.Display_Name);
1322 Action (Name_Buffer (1 .. Name_Len));
1323 end if;
1324 end For_Project;
1325
1326 procedure Get_Object_Dirs is
1327 new For_Every_Project_Imported (Integer, For_Project);
1328 Dummy : Integer := 1;
1329
1330 -- Start of processing for For_All_Object_Dirs
1331
1332 begin
1333 Get_Object_Dirs (Project, Dummy);
1334 end For_All_Object_Dirs;
1335
1336 -------------------------
1337 -- For_All_Source_Dirs --
1338 -------------------------
1339
1340 procedure For_All_Source_Dirs
1341 (Project : Project_Id;
1342 In_Tree : Project_Tree_Ref)
1343 is
1344 procedure For_Project (Prj : Project_Id; Dummy : in out Integer);
1345 -- Get all object directories of Prj
1346
1347 -----------------
1348 -- For_Project --
1349 -----------------
1350
1351 procedure For_Project (Prj : Project_Id; Dummy : in out Integer) is
1352 pragma Unreferenced (Dummy);
1353 Current : String_List_Id := Prj.Source_Dirs;
1354 The_String : String_Element;
1355
1356 begin
1357 -- If there are Ada sources, call action with the name of every
1358 -- source directory.
1359
1360 if Has_Ada_Sources (Project) then
1361 while Current /= Nil_String loop
1362 The_String := In_Tree.String_Elements.Table (Current);
1363 Action (Get_Name_String (The_String.Display_Value));
1364 Current := The_String.Next;
1365 end loop;
1366 end if;
1367 end For_Project;
1368
1369 procedure Get_Source_Dirs is
1370 new For_Every_Project_Imported (Integer, For_Project);
1371 Dummy : Integer := 1;
1372
1373 -- Start of processing for For_All_Source_Dirs
1374
1375 begin
1376 Get_Source_Dirs (Project, Dummy);
1377 end For_All_Source_Dirs;
1378
1379 -------------------
1380 -- Get_Reference --
1381 -------------------
1382
1383 procedure Get_Reference
1384 (Source_File_Name : String;
1385 In_Tree : Project_Tree_Ref;
1386 Project : out Project_Id;
1387 Path : out Path_Name_Type)
1388 is
1389 begin
1390 -- Body below could use some comments ???
1391
1392 if Current_Verbosity > Default then
1393 Write_Str ("Getting Reference_Of (""");
1394 Write_Str (Source_File_Name);
1395 Write_Str (""") ... ");
1396 end if;
1397
1398 declare
1399 Original_Name : String := Source_File_Name;
1400 Unit : Unit_Index;
1401
1402 begin
1403 Canonical_Case_File_Name (Original_Name);
1404 Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1405
1406 while Unit /= null loop
1407 if Unit.File_Names (Spec) /= null
1408 and then Unit.File_Names (Spec).File /= No_File
1409 and then
1410 (Namet.Get_Name_String
1411 (Unit.File_Names (Spec).File) = Original_Name
1412 or else (Unit.File_Names (Spec).Path /=
1413 No_Path_Information
1414 and then
1415 Namet.Get_Name_String
1416 (Unit.File_Names (Spec).Path.Name) =
1417 Original_Name))
1418 then
1419 Project := Ultimate_Extension_Of
1420 (Project => Unit.File_Names (Spec).Project);
1421 Path := Unit.File_Names (Spec).Path.Display_Name;
1422
1423 if Current_Verbosity > Default then
1424 Write_Str ("Done: Spec.");
1425 Write_Eol;
1426 end if;
1427
1428 return;
1429
1430 elsif Unit.File_Names (Impl) /= null
1431 and then Unit.File_Names (Impl).File /= No_File
1432 and then
1433 (Namet.Get_Name_String
1434 (Unit.File_Names (Impl).File) = Original_Name
1435 or else (Unit.File_Names (Impl).Path /=
1436 No_Path_Information
1437 and then Namet.Get_Name_String
1438 (Unit.File_Names (Impl).Path.Name) =
1439 Original_Name))
1440 then
1441 Project := Ultimate_Extension_Of
1442 (Project => Unit.File_Names (Impl).Project);
1443 Path := Unit.File_Names (Impl).Path.Display_Name;
1444
1445 if Current_Verbosity > Default then
1446 Write_Str ("Done: Body.");
1447 Write_Eol;
1448 end if;
1449
1450 return;
1451 end if;
1452
1453 Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1454 end loop;
1455 end;
1456
1457 Project := No_Project;
1458 Path := No_Path;
1459
1460 if Current_Verbosity > Default then
1461 Write_Str ("Cannot be found.");
1462 Write_Eol;
1463 end if;
1464 end Get_Reference;
1465
1466 ----------------
1467 -- Initialize --
1468 ----------------
1469
1470 procedure Initialize (In_Tree : Project_Tree_Ref) is
1471 begin
1472 In_Tree.Private_Part.Fill_Mapping_File := True;
1473 In_Tree.Private_Part.Current_Source_Path_File := No_Path;
1474 In_Tree.Private_Part.Current_Object_Path_File := No_Path;
1475 end Initialize;
1476
1477 -------------------
1478 -- Print_Sources --
1479 -------------------
1480
1481 -- Could use some comments in this body ???
1482
1483 procedure Print_Sources (In_Tree : Project_Tree_Ref) is
1484 Unit : Unit_Index;
1485
1486 begin
1487 Write_Line ("List of Sources:");
1488
1489 Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1490
1491 while Unit /= No_Unit_Index loop
1492 Write_Str (" ");
1493 Write_Line (Namet.Get_Name_String (Unit.Name));
1494
1495 if Unit.File_Names (Spec).File /= No_File then
1496 if Unit.File_Names (Spec).Project = No_Project then
1497 Write_Line (" No project");
1498
1499 else
1500 Write_Str (" Project: ");
1501 Get_Name_String
1502 (Unit.File_Names (Spec).Project.Path.Name);
1503 Write_Line (Name_Buffer (1 .. Name_Len));
1504 end if;
1505
1506 Write_Str (" spec: ");
1507 Write_Line
1508 (Namet.Get_Name_String
1509 (Unit.File_Names (Spec).File));
1510 end if;
1511
1512 if Unit.File_Names (Impl).File /= No_File then
1513 if Unit.File_Names (Impl).Project = No_Project then
1514 Write_Line (" No project");
1515
1516 else
1517 Write_Str (" Project: ");
1518 Get_Name_String
1519 (Unit.File_Names (Impl).Project.Path.Name);
1520 Write_Line (Name_Buffer (1 .. Name_Len));
1521 end if;
1522
1523 Write_Str (" body: ");
1524 Write_Line
1525 (Namet.Get_Name_String (Unit.File_Names (Impl).File));
1526 end if;
1527
1528 Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1529 end loop;
1530
1531 Write_Line ("end of List of Sources.");
1532 end Print_Sources;
1533
1534 ----------------
1535 -- Project_Of --
1536 ----------------
1537
1538 function Project_Of
1539 (Name : String;
1540 Main_Project : Project_Id;
1541 In_Tree : Project_Tree_Ref) return Project_Id
1542 is
1543 Result : Project_Id := No_Project;
1544
1545 Original_Name : String := Name;
1546
1547 Extended_Spec_Name : String :=
1548 Name & Spec_Suffix_Of (In_Tree, "ada", Main_Project.Naming);
1549 Extended_Body_Name : String :=
1550 Name & Body_Suffix_Of (In_Tree, "ada", Main_Project.Naming);
1551
1552 Unit : Unit_Index;
1553
1554 Current_Name : File_Name_Type;
1555 The_Original_Name : File_Name_Type;
1556 The_Spec_Name : File_Name_Type;
1557 The_Body_Name : File_Name_Type;
1558
1559 begin
1560 Canonical_Case_File_Name (Original_Name);
1561 Name_Len := Original_Name'Length;
1562 Name_Buffer (1 .. Name_Len) := Original_Name;
1563 The_Original_Name := Name_Find;
1564
1565 Canonical_Case_File_Name (Extended_Spec_Name);
1566 Name_Len := Extended_Spec_Name'Length;
1567 Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
1568 The_Spec_Name := Name_Find;
1569
1570 Canonical_Case_File_Name (Extended_Body_Name);
1571 Name_Len := Extended_Body_Name'Length;
1572 Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
1573 The_Body_Name := Name_Find;
1574
1575 Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1576
1577 while Unit /= null loop
1578 -- Case of a body present
1579
1580 if Unit.File_Names (Impl) /= null then
1581 Current_Name := Unit.File_Names (Impl).File;
1582
1583 -- If it has the name of the original name or the body name,
1584 -- we have found the project.
1585
1586 if Unit.Name = Name_Id (The_Original_Name)
1587 or else Current_Name = The_Original_Name
1588 or else Current_Name = The_Body_Name
1589 then
1590 Result := Unit.File_Names (Impl).Project;
1591 exit;
1592 end if;
1593 end if;
1594
1595 -- Check for spec
1596
1597 if Unit.File_Names (Spec) /= null then
1598 Current_Name := Unit.File_Names (Spec).File;
1599
1600 -- If name same as the original name, or the spec name, we have
1601 -- found the project.
1602
1603 if Unit.Name = Name_Id (The_Original_Name)
1604 or else Current_Name = The_Original_Name
1605 or else Current_Name = The_Spec_Name
1606 then
1607 Result := Unit.File_Names (Spec).Project;
1608 exit;
1609 end if;
1610 end if;
1611
1612 Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1613 end loop;
1614
1615 -- Get the ultimate extending project
1616
1617 if Result /= No_Project then
1618 while Result.Extended_By /= No_Project loop
1619 Result := Result.Extended_By;
1620 end loop;
1621 end if;
1622
1623 return Result;
1624 end Project_Of;
1625
1626 -------------------
1627 -- Set_Ada_Paths --
1628 -------------------
1629
1630 procedure Set_Ada_Paths
1631 (Project : Project_Id;
1632 In_Tree : Project_Tree_Ref;
1633 Including_Libraries : Boolean)
1634
1635 is
1636 Source_FD : File_Descriptor := Invalid_FD;
1637 Object_FD : File_Descriptor := Invalid_FD;
1638
1639 Process_Source_Dirs : Boolean := False;
1640 Process_Object_Dirs : Boolean := False;
1641
1642 Status : Boolean;
1643 -- For calls to Close
1644
1645 Len : Natural;
1646
1647 procedure Recursive_Add (Project : Project_Id; 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 (Project : Project_Id; Dummy : in out Boolean) is
1656 pragma Unreferenced (Dummy);
1657
1658 Path : Path_Name_Type;
1659
1660 begin
1661 -- ??? This is almost the equivalent of For_All_Source_Dirs
1662
1663 if Process_Source_Dirs then
1664
1665 -- Add to path all source directories of this project if there are
1666 -- Ada sources.
1667
1668 if Has_Ada_Sources (Project) then
1669 Add_To_Source_Path (Project.Source_Dirs, In_Tree);
1670 end if;
1671 end if;
1672
1673 if Process_Object_Dirs then
1674 Path := Get_Object_Directory
1675 (Project,
1676 Including_Libraries => Including_Libraries,
1677 Only_If_Ada => True);
1678
1679 if Path /= No_Path then
1680 Add_To_Object_Path (Path, In_Tree);
1681 end if;
1682 end if;
1683 end Recursive_Add;
1684
1685 procedure For_All_Projects is
1686 new For_Every_Project_Imported (Boolean, Recursive_Add);
1687 Dummy : Boolean := False;
1688
1689 -- Start of processing for Set_Ada_Paths
1690
1691 begin
1692 -- If it is the first time we call this procedure for this project,
1693 -- compute the source path and/or the object path.
1694
1695 if Project.Include_Path_File = No_Path then
1696 Process_Source_Dirs := True;
1697 Create_New_Path_File
1698 (In_Tree, Source_FD, Project.Include_Path_File);
1699 end if;
1700
1701 -- For the object path, we make a distinction depending on
1702 -- Including_Libraries.
1703
1704 if Including_Libraries then
1705 if Project.Objects_Path_File_With_Libs = No_Path then
1706 Process_Object_Dirs := True;
1707 Create_New_Path_File
1708 (In_Tree, Object_FD, Project.Objects_Path_File_With_Libs);
1709 end if;
1710
1711 else
1712 if Project.Objects_Path_File_Without_Libs = No_Path then
1713 Process_Object_Dirs := True;
1714 Create_New_Path_File
1715 (In_Tree, Object_FD, Project.Objects_Path_File_Without_Libs);
1716 end if;
1717 end if;
1718
1719 -- If there is something to do, set Seen to False for all projects,
1720 -- then call the recursive procedure Add for Project.
1721
1722 if Process_Source_Dirs or Process_Object_Dirs then
1723 Source_Path_Table.Set_Last (In_Tree.Private_Part.Source_Paths, 0);
1724 Object_Path_Table.Set_Last (In_Tree.Private_Part.Object_Paths, 0);
1725 For_All_Projects (Project, Dummy);
1726 end if;
1727
1728 -- Write and close any file that has been created
1729
1730 if Source_FD /= Invalid_FD then
1731 for Index in Source_Path_Table.First ..
1732 Source_Path_Table.Last
1733 (In_Tree.Private_Part.Source_Paths)
1734 loop
1735 Get_Name_String (In_Tree.Private_Part.Source_Paths.Table (Index));
1736 Name_Len := Name_Len + 1;
1737 Name_Buffer (Name_Len) := ASCII.LF;
1738 Len := Write (Source_FD, Name_Buffer (1)'Address, Name_Len);
1739
1740 if Len /= Name_Len then
1741 Prj.Com.Fail ("disk full");
1742 end if;
1743 end loop;
1744
1745 Close (Source_FD, Status);
1746
1747 if not Status then
1748 Prj.Com.Fail ("disk full");
1749 end if;
1750 end if;
1751
1752 if Object_FD /= Invalid_FD then
1753 for Index in Object_Path_Table.First ..
1754 Object_Path_Table.Last
1755 (In_Tree.Private_Part.Object_Paths)
1756 loop
1757 Get_Name_String (In_Tree.Private_Part.Object_Paths.Table (Index));
1758 Name_Len := Name_Len + 1;
1759 Name_Buffer (Name_Len) := ASCII.LF;
1760 Len := Write (Object_FD, Name_Buffer (1)'Address, Name_Len);
1761
1762 if Len /= Name_Len then
1763 Prj.Com.Fail ("disk full");
1764 end if;
1765 end loop;
1766
1767 Close (Object_FD, Status);
1768
1769 if not Status then
1770 Prj.Com.Fail ("disk full");
1771 end if;
1772 end if;
1773
1774 -- Set the env vars, if they need to be changed, and set the
1775 -- corresponding flags.
1776
1777 if In_Tree.Private_Part.Current_Source_Path_File /=
1778 Project.Include_Path_File
1779 then
1780 In_Tree.Private_Part.Current_Source_Path_File :=
1781 Project.Include_Path_File;
1782 Set_Path_File_Var
1783 (Project_Include_Path_File,
1784 Get_Name_String (In_Tree.Private_Part.Current_Source_Path_File));
1785 In_Tree.Private_Part.Ada_Prj_Include_File_Set := True;
1786 end if;
1787
1788 if Including_Libraries then
1789 if In_Tree.Private_Part.Current_Object_Path_File /=
1790 Project.Objects_Path_File_With_Libs
1791 then
1792 In_Tree.Private_Part.Current_Object_Path_File :=
1793 Project.Objects_Path_File_With_Libs;
1794 Set_Path_File_Var
1795 (Project_Objects_Path_File,
1796 Get_Name_String
1797 (In_Tree.Private_Part.Current_Object_Path_File));
1798 In_Tree.Private_Part.Ada_Prj_Objects_File_Set := True;
1799 end if;
1800
1801 else
1802 if In_Tree.Private_Part.Current_Object_Path_File /=
1803 Project.Objects_Path_File_Without_Libs
1804 then
1805 In_Tree.Private_Part.Current_Object_Path_File :=
1806 Project.Objects_Path_File_Without_Libs;
1807 Set_Path_File_Var
1808 (Project_Objects_Path_File,
1809 Get_Name_String
1810 (In_Tree.Private_Part.Current_Object_Path_File));
1811 In_Tree.Private_Part.Ada_Prj_Objects_File_Set := True;
1812 end if;
1813 end if;
1814 end Set_Ada_Paths;
1815
1816 ---------------------------------------------
1817 -- Set_Mapping_File_Initial_State_To_Empty --
1818 ---------------------------------------------
1819
1820 procedure Set_Mapping_File_Initial_State_To_Empty
1821 (In_Tree : Project_Tree_Ref)
1822 is
1823 begin
1824 In_Tree.Private_Part.Fill_Mapping_File := False;
1825 end Set_Mapping_File_Initial_State_To_Empty;
1826
1827 -----------------------
1828 -- Set_Path_File_Var --
1829 -----------------------
1830
1831 procedure Set_Path_File_Var (Name : String; Value : String) is
1832 Host_Spec : String_Access := To_Host_File_Spec (Value);
1833 begin
1834 if Host_Spec = null then
1835 Prj.Com.Fail
1836 ("could not convert file name """ & Value & """ to host spec");
1837 else
1838 Setenv (Name, Host_Spec.all);
1839 Free (Host_Spec);
1840 end if;
1841 end Set_Path_File_Var;
1842
1843 ---------------------------
1844 -- Ultimate_Extension_Of --
1845 ---------------------------
1846
1847 function Ultimate_Extension_Of
1848 (Project : Project_Id) return Project_Id
1849 is
1850 Result : Project_Id;
1851
1852 begin
1853 Result := Project;
1854 while Result.Extended_By /= No_Project loop
1855 Result := Result.Extended_By;
1856 end loop;
1857
1858 return Result;
1859 end Ultimate_Extension_Of;
1860
1861 end Prj.Env;