File : prj-util.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- P R J . U T I L --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2001-2015, 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 Ada.Containers.Indefinite_Ordered_Sets;
27 with Ada.Directories;
28 with Ada.Strings.Fixed; use Ada.Strings.Fixed;
29 with Ada.Strings.Maps; use Ada.Strings.Maps;
30 with Ada.Unchecked_Deallocation;
31
32 with GNAT.Case_Util; use GNAT.Case_Util;
33 with GNAT.Regexp; use GNAT.Regexp;
34
35 with ALI; use ALI;
36 with Osint; use Osint;
37 with Output; use Output;
38 with Opt;
39 with Prj.Com;
40 with Snames; use Snames;
41 with Table;
42 with Targparm; use Targparm;
43
44 with GNAT.HTable;
45
46 package body Prj.Util is
47
48 package Source_Info_Table is new Table.Table
49 (Table_Component_Type => Source_Info_Iterator,
50 Table_Index_Type => Natural,
51 Table_Low_Bound => 1,
52 Table_Initial => 10,
53 Table_Increment => 100,
54 Table_Name => "Makeutl.Source_Info_Table");
55
56 package Source_Info_Project_HTable is new GNAT.HTable.Simple_HTable
57 (Header_Num => Prj.Header_Num,
58 Element => Natural,
59 No_Element => 0,
60 Key => Name_Id,
61 Hash => Prj.Hash,
62 Equal => "=");
63
64 procedure Free is new Ada.Unchecked_Deallocation
65 (Text_File_Data, Text_File);
66
67 -----------
68 -- Close --
69 -----------
70
71 procedure Close (File : in out Text_File) is
72 Len : Integer;
73 Status : Boolean;
74
75 begin
76 if File = null then
77 Prj.Com.Fail ("Close attempted on an invalid Text_File");
78 end if;
79
80 if File.Out_File then
81 if File.Buffer_Len > 0 then
82 Len := Write (File.FD, File.Buffer'Address, File.Buffer_Len);
83
84 if Len /= File.Buffer_Len then
85 Prj.Com.Fail ("Unable to write to an out Text_File");
86 end if;
87 end if;
88
89 Close (File.FD, Status);
90
91 if not Status then
92 Prj.Com.Fail ("Unable to close an out Text_File");
93 end if;
94
95 else
96
97 -- Close in file, no need to test status, since this is a file that
98 -- we read, and the file was read successfully before we closed it.
99
100 Close (File.FD);
101 end if;
102
103 Free (File);
104 end Close;
105
106 ------------
107 -- Create --
108 ------------
109
110 procedure Create (File : out Text_File; Name : String) is
111 FD : File_Descriptor;
112 File_Name : String (1 .. Name'Length + 1);
113
114 begin
115 File_Name (1 .. Name'Length) := Name;
116 File_Name (File_Name'Last) := ASCII.NUL;
117 FD := Create_File (Name => File_Name'Address,
118 Fmode => GNAT.OS_Lib.Text);
119
120 if FD = Invalid_FD then
121 File := null;
122
123 else
124 File := new Text_File_Data;
125 File.FD := FD;
126 File.Out_File := True;
127 File.End_Of_File_Reached := True;
128 end if;
129 end Create;
130
131 ---------------
132 -- Duplicate --
133 ---------------
134
135 procedure Duplicate
136 (This : in out Name_List_Index;
137 Shared : Shared_Project_Tree_Data_Access)
138 is
139 Old_Current : Name_List_Index;
140 New_Current : Name_List_Index;
141
142 begin
143 if This /= No_Name_List then
144 Old_Current := This;
145 Name_List_Table.Increment_Last (Shared.Name_Lists);
146 New_Current := Name_List_Table.Last (Shared.Name_Lists);
147 This := New_Current;
148 Shared.Name_Lists.Table (New_Current) :=
149 (Shared.Name_Lists.Table (Old_Current).Name, No_Name_List);
150
151 loop
152 Old_Current := Shared.Name_Lists.Table (Old_Current).Next;
153 exit when Old_Current = No_Name_List;
154 Shared.Name_Lists.Table (New_Current).Next := New_Current + 1;
155 Name_List_Table.Increment_Last (Shared.Name_Lists);
156 New_Current := New_Current + 1;
157 Shared.Name_Lists.Table (New_Current) :=
158 (Shared.Name_Lists.Table (Old_Current).Name, No_Name_List);
159 end loop;
160 end if;
161 end Duplicate;
162
163 -----------------
164 -- End_Of_File --
165 -----------------
166
167 function End_Of_File (File : Text_File) return Boolean is
168 begin
169 if File = null then
170 Prj.Com.Fail ("End_Of_File attempted on an invalid Text_File");
171 end if;
172
173 return File.End_Of_File_Reached;
174 end End_Of_File;
175
176 -------------------
177 -- Executable_Of --
178 -------------------
179
180 function Executable_Of
181 (Project : Project_Id;
182 Shared : Shared_Project_Tree_Data_Access;
183 Main : File_Name_Type;
184 Index : Int;
185 Ada_Main : Boolean := True;
186 Language : String := "";
187 Include_Suffix : Boolean := True) return File_Name_Type
188 is
189 pragma Assert (Project /= No_Project);
190
191 The_Packages : constant Package_Id := Project.Decl.Packages;
192
193 Builder_Package : constant Prj.Package_Id :=
194 Prj.Util.Value_Of
195 (Name => Name_Builder,
196 In_Packages => The_Packages,
197 Shared => Shared);
198
199 Executable : Variable_Value :=
200 Prj.Util.Value_Of
201 (Name => Name_Id (Main),
202 Index => Index,
203 Attribute_Or_Array_Name => Name_Executable,
204 In_Package => Builder_Package,
205 Shared => Shared);
206
207 Lang : Language_Ptr;
208
209 Spec_Suffix : Name_Id := No_Name;
210 Body_Suffix : Name_Id := No_Name;
211
212 Spec_Suffix_Length : Natural := 0;
213 Body_Suffix_Length : Natural := 0;
214
215 procedure Get_Suffixes
216 (B_Suffix : File_Name_Type;
217 S_Suffix : File_Name_Type);
218 -- Get the non empty suffixes in variables Spec_Suffix and Body_Suffix
219
220 function Add_Suffix (File : File_Name_Type) return File_Name_Type;
221 -- Return the name of the executable, based on File, and adding the
222 -- executable suffix if needed
223
224 ------------------
225 -- Get_Suffixes --
226 ------------------
227
228 procedure Get_Suffixes
229 (B_Suffix : File_Name_Type;
230 S_Suffix : File_Name_Type)
231 is
232 begin
233 if B_Suffix /= No_File then
234 Body_Suffix := Name_Id (B_Suffix);
235 Body_Suffix_Length := Natural (Length_Of_Name (Body_Suffix));
236 end if;
237
238 if S_Suffix /= No_File then
239 Spec_Suffix := Name_Id (S_Suffix);
240 Spec_Suffix_Length := Natural (Length_Of_Name (Spec_Suffix));
241 end if;
242 end Get_Suffixes;
243
244 ----------------
245 -- Add_Suffix --
246 ----------------
247
248 function Add_Suffix (File : File_Name_Type) return File_Name_Type is
249 Saved_EEOT : constant Name_Id := Executable_Extension_On_Target;
250 Result : File_Name_Type;
251 Suffix_From_Project : Variable_Value;
252 begin
253 if Include_Suffix then
254 if Project.Config.Executable_Suffix /= No_Name then
255 Executable_Extension_On_Target :=
256 Project.Config.Executable_Suffix;
257 end if;
258
259 Result := Executable_Name (File);
260 Executable_Extension_On_Target := Saved_EEOT;
261 return Result;
262
263 elsif Builder_Package /= No_Package then
264
265 -- If the suffix is specified in the project itself, as opposed to
266 -- the config file, it needs to be taken into account. However,
267 -- when the project was processed, in both cases the suffix was
268 -- stored in Project.Config, so get it from the project again.
269
270 Suffix_From_Project :=
271 Prj.Util.Value_Of
272 (Variable_Name => Name_Executable_Suffix,
273 In_Variables =>
274 Shared.Packages.Table (Builder_Package).Decl.Attributes,
275 Shared => Shared);
276
277 if Suffix_From_Project /= Nil_Variable_Value
278 and then Suffix_From_Project.Value /= No_Name
279 then
280 Executable_Extension_On_Target := Suffix_From_Project.Value;
281 Result := Executable_Name (File);
282 Executable_Extension_On_Target := Saved_EEOT;
283 return Result;
284 end if;
285 end if;
286
287 return File;
288 end Add_Suffix;
289
290 -- Start of processing for Executable_Of
291
292 begin
293 if Ada_Main then
294 Lang := Get_Language_From_Name (Project, "ada");
295 elsif Language /= "" then
296 Lang := Get_Language_From_Name (Project, Language);
297 end if;
298
299 if Lang /= null then
300 Get_Suffixes
301 (B_Suffix => Lang.Config.Naming_Data.Body_Suffix,
302 S_Suffix => Lang.Config.Naming_Data.Spec_Suffix);
303 end if;
304
305 if Builder_Package /= No_Package then
306 if Executable = Nil_Variable_Value and then Ada_Main then
307 Get_Name_String (Main);
308
309 -- Try as index the name minus the implementation suffix or minus
310 -- the specification suffix.
311
312 declare
313 Name : constant String (1 .. Name_Len) :=
314 Name_Buffer (1 .. Name_Len);
315 Last : Positive := Name_Len;
316
317 Truncated : Boolean := False;
318
319 begin
320 if Body_Suffix /= No_Name
321 and then Last > Natural (Length_Of_Name (Body_Suffix))
322 and then Name (Last - Body_Suffix_Length + 1 .. Last) =
323 Get_Name_String (Body_Suffix)
324 then
325 Truncated := True;
326 Last := Last - Body_Suffix_Length;
327 end if;
328
329 if Spec_Suffix /= No_Name
330 and then not Truncated
331 and then Last > Spec_Suffix_Length
332 and then Name (Last - Spec_Suffix_Length + 1 .. Last) =
333 Get_Name_String (Spec_Suffix)
334 then
335 Truncated := True;
336 Last := Last - Spec_Suffix_Length;
337 end if;
338
339 if Truncated then
340 Name_Len := Last;
341 Name_Buffer (1 .. Name_Len) := Name (1 .. Last);
342 Executable :=
343 Prj.Util.Value_Of
344 (Name => Name_Find,
345 Index => 0,
346 Attribute_Or_Array_Name => Name_Executable,
347 In_Package => Builder_Package,
348 Shared => Shared);
349 end if;
350 end;
351 end if;
352
353 -- If we have found an Executable attribute, return its value,
354 -- possibly suffixed by the executable suffix.
355
356 if Executable /= Nil_Variable_Value
357 and then Executable.Value /= No_Name
358 and then Length_Of_Name (Executable.Value) /= 0
359 then
360 return Add_Suffix (File_Name_Type (Executable.Value));
361 end if;
362 end if;
363
364 Get_Name_String (Main);
365
366 -- If there is a body suffix or a spec suffix, remove this suffix,
367 -- otherwise remove any suffix ('.' followed by other characters), if
368 -- there is one.
369
370 if Body_Suffix /= No_Name
371 and then Name_Len > Body_Suffix_Length
372 and then Name_Buffer (Name_Len - Body_Suffix_Length + 1 .. Name_Len) =
373 Get_Name_String (Body_Suffix)
374 then
375 -- Found the body termination, remove it
376
377 Name_Len := Name_Len - Body_Suffix_Length;
378
379 elsif Spec_Suffix /= No_Name
380 and then Name_Len > Spec_Suffix_Length
381 and then
382 Name_Buffer (Name_Len - Spec_Suffix_Length + 1 .. Name_Len) =
383 Get_Name_String (Spec_Suffix)
384 then
385 -- Found the spec termination, remove it
386
387 Name_Len := Name_Len - Spec_Suffix_Length;
388
389 else
390 -- Remove any suffix, if there is one
391
392 Get_Name_String (Strip_Suffix (Main));
393 end if;
394
395 return Add_Suffix (Name_Find);
396 end Executable_Of;
397
398 ---------------------------
399 -- For_Interface_Sources --
400 ---------------------------
401
402 procedure For_Interface_Sources
403 (Tree : Project_Tree_Ref;
404 Project : Project_Id)
405 is
406 use Ada;
407 use type Ada.Containers.Count_Type;
408
409 package Dep_Names is new Containers.Indefinite_Ordered_Sets (String);
410
411 function Load_ALI (Filename : String) return ALI_Id;
412 -- Load an ALI file and return its id
413
414 --------------
415 -- Load_ALI --
416 --------------
417
418 function Load_ALI (Filename : String) return ALI_Id is
419 Result : ALI_Id := No_ALI_Id;
420 Text : Text_Buffer_Ptr;
421 Lib_File : File_Name_Type;
422
423 begin
424 if Directories.Exists (Filename) then
425 Name_Len := 0;
426 Add_Str_To_Name_Buffer (Filename);
427 Lib_File := Name_Find;
428 Text := Osint.Read_Library_Info (Lib_File);
429 Result :=
430 ALI.Scan_ALI
431 (Lib_File,
432 Text,
433 Ignore_ED => False,
434 Err => True,
435 Read_Lines => "UD");
436 Free (Text);
437 end if;
438
439 return Result;
440 end Load_ALI;
441
442 -- Local declarations
443
444 Iter : Source_Iterator;
445 Sid : Source_Id;
446 ALI : ALI_Id;
447
448 First_Unit : Unit_Id;
449 Second_Unit : Unit_Id;
450 Body_Needed : Boolean;
451 Deps : Dep_Names.Set;
452
453 -- Start of processing for For_Interface_Sources
454
455 begin
456 if Project.Qualifier = Aggregate_Library then
457 Iter := For_Each_Source (Tree);
458 else
459 Iter := For_Each_Source (Tree, Project);
460 end if;
461
462 -- First look at each spec, check if the body is needed
463
464 loop
465 Sid := Element (Iter);
466 exit when Sid = No_Source;
467
468 -- Skip sources that are removed/excluded and sources not part of
469 -- the interface for standalone libraries.
470
471 if Sid.Kind = Spec
472 and then (not Sid.Project.Externally_Built
473 or else Sid.Project = Project)
474 and then not Sid.Locally_Removed
475 and then (Project.Standalone_Library = No
476 or else Sid.Declared_In_Interfaces)
477
478 -- Handle case of non-compilable languages
479
480 and then Sid.Dep_Name /= No_File
481 then
482 Action (Sid);
483
484 -- Check ALI for dependencies on body and sep
485
486 ALI :=
487 Load_ALI
488 (Get_Name_String (Get_Object_Directory (Sid.Project, True))
489 & Get_Name_String (Sid.Dep_Name));
490
491 if ALI /= No_ALI_Id then
492 First_Unit := ALIs.Table (ALI).First_Unit;
493 Second_Unit := No_Unit_Id;
494 Body_Needed := True;
495
496 -- If there is both a spec and a body, check if both needed
497
498 if Units.Table (First_Unit).Utype = Is_Body then
499 Second_Unit := ALIs.Table (ALI).Last_Unit;
500
501 -- If the body is not needed, then reset First_Unit
502
503 if not Units.Table (Second_Unit).Body_Needed_For_SAL then
504 Body_Needed := False;
505 end if;
506
507 elsif Units.Table (First_Unit).Utype = Is_Spec_Only then
508 Body_Needed := False;
509 end if;
510
511 -- Handle all the separates, if any
512
513 if Body_Needed then
514 if Other_Part (Sid) /= null then
515 Deps.Include (Get_Name_String (Other_Part (Sid).File));
516 end if;
517
518 for Dep in ALIs.Table (ALI).First_Sdep ..
519 ALIs.Table (ALI).Last_Sdep
520 loop
521 if Sdep.Table (Dep).Subunit_Name /= No_Name then
522 Deps.Include
523 (Get_Name_String (Sdep.Table (Dep).Sfile));
524 end if;
525 end loop;
526 end if;
527 end if;
528 end if;
529
530 Next (Iter);
531 end loop;
532
533 -- Now handle the bodies and separates if needed
534
535 if Deps.Length /= 0 then
536 if Project.Qualifier = Aggregate_Library then
537 Iter := For_Each_Source (Tree);
538 else
539 Iter := For_Each_Source (Tree, Project);
540 end if;
541
542 loop
543 Sid := Element (Iter);
544 exit when Sid = No_Source;
545
546 if Sid.Kind /= Spec
547 and then Deps.Contains (Get_Name_String (Sid.File))
548 then
549 Action (Sid);
550 end if;
551
552 Next (Iter);
553 end loop;
554 end if;
555 end For_Interface_Sources;
556
557 --------------
558 -- Get_Line --
559 --------------
560
561 procedure Get_Line
562 (File : Text_File;
563 Line : out String;
564 Last : out Natural)
565 is
566 C : Character;
567
568 procedure Advance;
569
570 -------------
571 -- Advance --
572 -------------
573
574 procedure Advance is
575 begin
576 if File.Cursor = File.Buffer_Len then
577 File.Buffer_Len :=
578 Read
579 (FD => File.FD,
580 A => File.Buffer'Address,
581 N => File.Buffer'Length);
582
583 if File.Buffer_Len = 0 then
584 File.End_Of_File_Reached := True;
585 return;
586 else
587 File.Cursor := 1;
588 end if;
589
590 else
591 File.Cursor := File.Cursor + 1;
592 end if;
593 end Advance;
594
595 -- Start of processing for Get_Line
596
597 begin
598 if File = null then
599 Prj.Com.Fail ("Get_Line attempted on an invalid Text_File");
600
601 elsif File.Out_File then
602 Prj.Com.Fail ("Get_Line attempted on an out file");
603 end if;
604
605 Last := Line'First - 1;
606
607 if not File.End_Of_File_Reached then
608 loop
609 C := File.Buffer (File.Cursor);
610 exit when C = ASCII.CR or else C = ASCII.LF;
611 Last := Last + 1;
612 Line (Last) := C;
613 Advance;
614
615 if File.End_Of_File_Reached then
616 return;
617 end if;
618
619 exit when Last = Line'Last;
620 end loop;
621
622 if C = ASCII.CR or else C = ASCII.LF then
623 Advance;
624
625 if File.End_Of_File_Reached then
626 return;
627 end if;
628 end if;
629
630 if C = ASCII.CR
631 and then File.Buffer (File.Cursor) = ASCII.LF
632 then
633 Advance;
634 end if;
635 end if;
636 end Get_Line;
637
638 ----------------
639 -- Initialize --
640 ----------------
641
642 procedure Initialize
643 (Iter : out Source_Info_Iterator;
644 For_Project : Name_Id)
645 is
646 Ind : constant Natural := Source_Info_Project_HTable.Get (For_Project);
647 begin
648 if Ind = 0 then
649 Iter := (No_Source_Info, 0);
650 else
651 Iter := Source_Info_Table.Table (Ind);
652 end if;
653 end Initialize;
654
655 --------------
656 -- Is_Valid --
657 --------------
658
659 function Is_Valid (File : Text_File) return Boolean is
660 begin
661 return File /= null;
662 end Is_Valid;
663
664 ----------
665 -- Next --
666 ----------
667
668 procedure Next (Iter : in out Source_Info_Iterator) is
669 begin
670 if Iter.Next = 0 then
671 Iter.Info := No_Source_Info;
672
673 else
674 Iter := Source_Info_Table.Table (Iter.Next);
675 end if;
676 end Next;
677
678 ----------
679 -- Open --
680 ----------
681
682 procedure Open (File : out Text_File; Name : String) is
683 FD : File_Descriptor;
684 File_Name : String (1 .. Name'Length + 1);
685
686 begin
687 File_Name (1 .. Name'Length) := Name;
688 File_Name (File_Name'Last) := ASCII.NUL;
689 FD := Open_Read (Name => File_Name'Address,
690 Fmode => GNAT.OS_Lib.Text);
691
692 if FD = Invalid_FD then
693 File := null;
694
695 else
696 File := new Text_File_Data;
697 File.FD := FD;
698 File.Buffer_Len :=
699 Read (FD => FD,
700 A => File.Buffer'Address,
701 N => File.Buffer'Length);
702
703 if File.Buffer_Len = 0 then
704 File.End_Of_File_Reached := True;
705 else
706 File.Cursor := 1;
707 end if;
708 end if;
709 end Open;
710
711 ---------
712 -- Put --
713 ---------
714
715 procedure Put
716 (Into_List : in out Name_List_Index;
717 From_List : String_List_Id;
718 In_Tree : Project_Tree_Ref;
719 Lower_Case : Boolean := False)
720 is
721 Shared : constant Shared_Project_Tree_Data_Access := In_Tree.Shared;
722
723 Current_Name : Name_List_Index;
724 List : String_List_Id;
725 Element : String_Element;
726 Last : Name_List_Index :=
727 Name_List_Table.Last (Shared.Name_Lists);
728 Value : Name_Id;
729
730 begin
731 Current_Name := Into_List;
732 while Current_Name /= No_Name_List
733 and then Shared.Name_Lists.Table (Current_Name).Next /= No_Name_List
734 loop
735 Current_Name := Shared.Name_Lists.Table (Current_Name).Next;
736 end loop;
737
738 List := From_List;
739 while List /= Nil_String loop
740 Element := Shared.String_Elements.Table (List);
741 Value := Element.Value;
742
743 if Lower_Case then
744 Get_Name_String (Value);
745 To_Lower (Name_Buffer (1 .. Name_Len));
746 Value := Name_Find;
747 end if;
748
749 Name_List_Table.Append
750 (Shared.Name_Lists, (Name => Value, Next => No_Name_List));
751
752 Last := Last + 1;
753
754 if Current_Name = No_Name_List then
755 Into_List := Last;
756 else
757 Shared.Name_Lists.Table (Current_Name).Next := Last;
758 end if;
759
760 Current_Name := Last;
761
762 List := Element.Next;
763 end loop;
764 end Put;
765
766 procedure Put (File : Text_File; S : String) is
767 Len : Integer;
768 begin
769 if File = null then
770 Prj.Com.Fail ("Attempted to write on an invalid Text_File");
771
772 elsif not File.Out_File then
773 Prj.Com.Fail ("Attempted to write an in Text_File");
774 end if;
775
776 if File.Buffer_Len + S'Length > File.Buffer'Last then
777 -- Write buffer
778 Len := Write (File.FD, File.Buffer'Address, File.Buffer_Len);
779
780 if Len /= File.Buffer_Len then
781 Prj.Com.Fail ("Failed to write to an out Text_File");
782 end if;
783
784 File.Buffer_Len := 0;
785 end if;
786
787 File.Buffer (File.Buffer_Len + 1 .. File.Buffer_Len + S'Length) := S;
788 File.Buffer_Len := File.Buffer_Len + S'Length;
789 end Put;
790
791 --------------
792 -- Put_Line --
793 --------------
794
795 procedure Put_Line (File : Text_File; Line : String) is
796 L : String (1 .. Line'Length + 1);
797 begin
798 L (1 .. Line'Length) := Line;
799 L (L'Last) := ASCII.LF;
800 Put (File, L);
801 end Put_Line;
802
803 -------------------
804 -- Relative_Path --
805 -------------------
806
807 function Relative_Path (Pathname : String; To : String) return String is
808 function Ensure_Directory (Path : String) return String;
809 -- Returns Path with an added directory separator if needed
810
811 ----------------------
812 -- Ensure_Directory --
813 ----------------------
814
815 function Ensure_Directory (Path : String) return String is
816 begin
817 if Path'Length = 0
818 or else Path (Path'Last) = Directory_Separator
819 or else Path (Path'Last) = '/' -- on Windows check also for /
820 then
821 return Path;
822 else
823 return Path & Directory_Separator;
824 end if;
825 end Ensure_Directory;
826
827 -- Local variables
828
829 Dir_Sep_Map : constant Character_Mapping := To_Mapping ("\", "/");
830
831 P : String (1 .. Pathname'Length) := Pathname;
832 T : String (1 .. To'Length) := To;
833
834 Pi : Natural; -- common prefix ending
835 N : Natural := 0;
836
837 -- Start of processing for Relative_Path
838
839 begin
840 pragma Assert (Is_Absolute_Path (Pathname));
841 pragma Assert (Is_Absolute_Path (To));
842
843 -- Use canonical directory separator
844
845 Translate (Source => P, Mapping => Dir_Sep_Map);
846 Translate (Source => T, Mapping => Dir_Sep_Map);
847
848 -- First check for common prefix
849
850 Pi := 1;
851 while Pi < P'Last and then Pi < T'Last and then P (Pi) = T (Pi) loop
852 Pi := Pi + 1;
853 end loop;
854
855 -- Cut common prefix at a directory separator
856
857 while Pi > P'First and then P (Pi) /= '/' loop
858 Pi := Pi - 1;
859 end loop;
860
861 -- Count directory under prefix in P, these will be replaced by the
862 -- corresponding number of "..".
863
864 N := Count (T (Pi + 1 .. T'Last), "/");
865
866 if T (T'Last) /= '/' then
867 N := N + 1;
868 end if;
869
870 return N * "../" & Ensure_Directory (P (Pi + 1 .. P'Last));
871 end Relative_Path;
872
873 ---------------------------
874 -- Read_Source_Info_File --
875 ---------------------------
876
877 procedure Read_Source_Info_File (Tree : Project_Tree_Ref) is
878 File : Text_File;
879 Info : Source_Info_Iterator;
880 Proj : Name_Id;
881
882 procedure Report_Error;
883
884 ------------------
885 -- Report_Error --
886 ------------------
887
888 procedure Report_Error is
889 begin
890 Write_Line ("errors in source info file """ &
891 Tree.Source_Info_File_Name.all & '"');
892 Tree.Source_Info_File_Exists := False;
893 end Report_Error;
894
895 begin
896 Source_Info_Project_HTable.Reset;
897 Source_Info_Table.Init;
898
899 if Tree.Source_Info_File_Name = null then
900 Tree.Source_Info_File_Exists := False;
901 return;
902 end if;
903
904 Open (File, Tree.Source_Info_File_Name.all);
905
906 if not Is_Valid (File) then
907 if Opt.Verbose_Mode then
908 Write_Line ("source info file " & Tree.Source_Info_File_Name.all &
909 " does not exist");
910 end if;
911
912 Tree.Source_Info_File_Exists := False;
913 return;
914 end if;
915
916 Tree.Source_Info_File_Exists := True;
917
918 if Opt.Verbose_Mode then
919 Write_Line ("Reading source info file " &
920 Tree.Source_Info_File_Name.all);
921 end if;
922
923 Source_Loop :
924 while not End_Of_File (File) loop
925 Info := (new Source_Info_Data, 0);
926 Source_Info_Table.Increment_Last;
927
928 -- project name
929 Get_Line (File, Name_Buffer, Name_Len);
930 Proj := Name_Find;
931 Info.Info.Project := Proj;
932 Info.Next := Source_Info_Project_HTable.Get (Proj);
933 Source_Info_Project_HTable.Set (Proj, Source_Info_Table.Last);
934
935 if End_Of_File (File) then
936 Report_Error;
937 exit Source_Loop;
938 end if;
939
940 -- language name
941 Get_Line (File, Name_Buffer, Name_Len);
942 Info.Info.Language := Name_Find;
943
944 if End_Of_File (File) then
945 Report_Error;
946 exit Source_Loop;
947 end if;
948
949 -- kind
950 Get_Line (File, Name_Buffer, Name_Len);
951 Info.Info.Kind := Source_Kind'Value (Name_Buffer (1 .. Name_Len));
952
953 if End_Of_File (File) then
954 Report_Error;
955 exit Source_Loop;
956 end if;
957
958 -- display path name
959 Get_Line (File, Name_Buffer, Name_Len);
960 Info.Info.Display_Path_Name := Name_Find;
961 Info.Info.Path_Name := Info.Info.Display_Path_Name;
962
963 if End_Of_File (File) then
964 Report_Error;
965 exit Source_Loop;
966 end if;
967
968 -- optional fields
969 Option_Loop :
970 loop
971 Get_Line (File, Name_Buffer, Name_Len);
972 exit Option_Loop when Name_Len = 0;
973
974 if Name_Len <= 2 then
975 Report_Error;
976 exit Source_Loop;
977
978 else
979 if Name_Buffer (1 .. 2) = "P=" then
980 Name_Buffer (1 .. Name_Len - 2) :=
981 Name_Buffer (3 .. Name_Len);
982 Name_Len := Name_Len - 2;
983 Info.Info.Path_Name := Name_Find;
984
985 elsif Name_Buffer (1 .. 2) = "U=" then
986 Name_Buffer (1 .. Name_Len - 2) :=
987 Name_Buffer (3 .. Name_Len);
988 Name_Len := Name_Len - 2;
989 Info.Info.Unit_Name := Name_Find;
990
991 elsif Name_Buffer (1 .. 2) = "I=" then
992 Info.Info.Index := Int'Value (Name_Buffer (3 .. Name_Len));
993
994 elsif Name_Buffer (1 .. Name_Len) = "N=Y" then
995 Info.Info.Naming_Exception := Yes;
996
997 elsif Name_Buffer (1 .. Name_Len) = "N=I" then
998 Info.Info.Naming_Exception := Inherited;
999
1000 else
1001 Report_Error;
1002 exit Source_Loop;
1003 end if;
1004 end if;
1005 end loop Option_Loop;
1006
1007 Source_Info_Table.Table (Source_Info_Table.Last) := Info;
1008 end loop Source_Loop;
1009
1010 Close (File);
1011
1012 exception
1013 when others =>
1014 Close (File);
1015 Report_Error;
1016 end Read_Source_Info_File;
1017
1018 --------------------
1019 -- Source_Info_Of --
1020 --------------------
1021
1022 function Source_Info_Of (Iter : Source_Info_Iterator) return Source_Info is
1023 begin
1024 return Iter.Info;
1025 end Source_Info_Of;
1026
1027 --------------
1028 -- Value_Of --
1029 --------------
1030
1031 function Value_Of
1032 (Variable : Variable_Value;
1033 Default : String) return String
1034 is
1035 begin
1036 if Variable.Kind /= Single
1037 or else Variable.Default
1038 or else Variable.Value = No_Name
1039 then
1040 return Default;
1041 else
1042 return Get_Name_String (Variable.Value);
1043 end if;
1044 end Value_Of;
1045
1046 function Value_Of
1047 (Index : Name_Id;
1048 In_Array : Array_Element_Id;
1049 Shared : Shared_Project_Tree_Data_Access) return Name_Id
1050 is
1051
1052 Current : Array_Element_Id;
1053 Element : Array_Element;
1054 Real_Index : Name_Id := Index;
1055
1056 begin
1057 Current := In_Array;
1058
1059 if Current = No_Array_Element then
1060 return No_Name;
1061 end if;
1062
1063 Element := Shared.Array_Elements.Table (Current);
1064
1065 if not Element.Index_Case_Sensitive then
1066 Get_Name_String (Index);
1067 To_Lower (Name_Buffer (1 .. Name_Len));
1068 Real_Index := Name_Find;
1069 end if;
1070
1071 while Current /= No_Array_Element loop
1072 Element := Shared.Array_Elements.Table (Current);
1073
1074 if Real_Index = Element.Index then
1075 exit when Element.Value.Kind /= Single;
1076 exit when Element.Value.Value = Empty_String;
1077 return Element.Value.Value;
1078 else
1079 Current := Element.Next;
1080 end if;
1081 end loop;
1082
1083 return No_Name;
1084 end Value_Of;
1085
1086 function Value_Of
1087 (Index : Name_Id;
1088 Src_Index : Int := 0;
1089 In_Array : Array_Element_Id;
1090 Shared : Shared_Project_Tree_Data_Access;
1091 Force_Lower_Case_Index : Boolean := False;
1092 Allow_Wildcards : Boolean := False) return Variable_Value
1093 is
1094 Current : Array_Element_Id;
1095 Element : Array_Element;
1096 Real_Index_1 : Name_Id;
1097 Real_Index_2 : Name_Id;
1098
1099 begin
1100 Current := In_Array;
1101
1102 if Current = No_Array_Element then
1103 return Nil_Variable_Value;
1104 end if;
1105
1106 Element := Shared.Array_Elements.Table (Current);
1107
1108 Real_Index_1 := Index;
1109
1110 if not Element.Index_Case_Sensitive or else Force_Lower_Case_Index then
1111 if Index /= All_Other_Names then
1112 Get_Name_String (Index);
1113 To_Lower (Name_Buffer (1 .. Name_Len));
1114 Real_Index_1 := Name_Find;
1115 end if;
1116 end if;
1117
1118 while Current /= No_Array_Element loop
1119 Element := Shared.Array_Elements.Table (Current);
1120 Real_Index_2 := Element.Index;
1121
1122 if not Element.Index_Case_Sensitive
1123 or else Force_Lower_Case_Index
1124 then
1125 if Element.Index /= All_Other_Names then
1126 Get_Name_String (Element.Index);
1127 To_Lower (Name_Buffer (1 .. Name_Len));
1128 Real_Index_2 := Name_Find;
1129 end if;
1130 end if;
1131
1132 if Src_Index = Element.Src_Index and then
1133 (Real_Index_1 = Real_Index_2 or else
1134 (Real_Index_2 /= All_Other_Names and then
1135 Allow_Wildcards and then
1136 Match (Get_Name_String (Real_Index_1),
1137 Compile (Get_Name_String (Real_Index_2),
1138 Glob => True))))
1139 then
1140 return Element.Value;
1141 else
1142 Current := Element.Next;
1143 end if;
1144 end loop;
1145
1146 return Nil_Variable_Value;
1147 end Value_Of;
1148
1149 function Value_Of
1150 (Name : Name_Id;
1151 Index : Int := 0;
1152 Attribute_Or_Array_Name : Name_Id;
1153 In_Package : Package_Id;
1154 Shared : Shared_Project_Tree_Data_Access;
1155 Force_Lower_Case_Index : Boolean := False;
1156 Allow_Wildcards : Boolean := False) return Variable_Value
1157 is
1158 The_Array : Array_Element_Id;
1159 The_Attribute : Variable_Value := Nil_Variable_Value;
1160
1161 begin
1162 if In_Package /= No_Package then
1163
1164 -- First, look if there is an array element that fits
1165
1166 The_Array :=
1167 Value_Of
1168 (Name => Attribute_Or_Array_Name,
1169 In_Arrays => Shared.Packages.Table (In_Package).Decl.Arrays,
1170 Shared => Shared);
1171 The_Attribute :=
1172 Value_Of
1173 (Index => Name,
1174 Src_Index => Index,
1175 In_Array => The_Array,
1176 Shared => Shared,
1177 Force_Lower_Case_Index => Force_Lower_Case_Index,
1178 Allow_Wildcards => Allow_Wildcards);
1179
1180 -- If there is no array element, look for a variable
1181
1182 if The_Attribute = Nil_Variable_Value then
1183 The_Attribute :=
1184 Value_Of
1185 (Variable_Name => Attribute_Or_Array_Name,
1186 In_Variables => Shared.Packages.Table
1187 (In_Package).Decl.Attributes,
1188 Shared => Shared);
1189 end if;
1190 end if;
1191
1192 return The_Attribute;
1193 end Value_Of;
1194
1195 function Value_Of
1196 (Index : Name_Id;
1197 In_Array : Name_Id;
1198 In_Arrays : Array_Id;
1199 Shared : Shared_Project_Tree_Data_Access) return Name_Id
1200 is
1201 Current : Array_Id;
1202 The_Array : Array_Data;
1203
1204 begin
1205 Current := In_Arrays;
1206 while Current /= No_Array loop
1207 The_Array := Shared.Arrays.Table (Current);
1208 if The_Array.Name = In_Array then
1209 return Value_Of
1210 (Index, In_Array => The_Array.Value, Shared => Shared);
1211 else
1212 Current := The_Array.Next;
1213 end if;
1214 end loop;
1215
1216 return No_Name;
1217 end Value_Of;
1218
1219 function Value_Of
1220 (Name : Name_Id;
1221 In_Arrays : Array_Id;
1222 Shared : Shared_Project_Tree_Data_Access) return Array_Element_Id
1223 is
1224 Current : Array_Id;
1225 The_Array : Array_Data;
1226
1227 begin
1228 Current := In_Arrays;
1229 while Current /= No_Array loop
1230 The_Array := Shared.Arrays.Table (Current);
1231
1232 if The_Array.Name = Name then
1233 return The_Array.Value;
1234 else
1235 Current := The_Array.Next;
1236 end if;
1237 end loop;
1238
1239 return No_Array_Element;
1240 end Value_Of;
1241
1242 function Value_Of
1243 (Name : Name_Id;
1244 In_Packages : Package_Id;
1245 Shared : Shared_Project_Tree_Data_Access) return Package_Id
1246 is
1247 Current : Package_Id;
1248 The_Package : Package_Element;
1249
1250 begin
1251 Current := In_Packages;
1252 while Current /= No_Package loop
1253 The_Package := Shared.Packages.Table (Current);
1254 exit when The_Package.Name /= No_Name
1255 and then The_Package.Name = Name;
1256 Current := The_Package.Next;
1257 end loop;
1258
1259 return Current;
1260 end Value_Of;
1261
1262 function Value_Of
1263 (Variable_Name : Name_Id;
1264 In_Variables : Variable_Id;
1265 Shared : Shared_Project_Tree_Data_Access) return Variable_Value
1266 is
1267 Current : Variable_Id;
1268 The_Variable : Variable;
1269
1270 begin
1271 Current := In_Variables;
1272 while Current /= No_Variable loop
1273 The_Variable := Shared.Variable_Elements.Table (Current);
1274
1275 if Variable_Name = The_Variable.Name then
1276 return The_Variable.Value;
1277 else
1278 Current := The_Variable.Next;
1279 end if;
1280 end loop;
1281
1282 return Nil_Variable_Value;
1283 end Value_Of;
1284
1285 ----------------------------
1286 -- Write_Source_Info_File --
1287 ----------------------------
1288
1289 procedure Write_Source_Info_File (Tree : Project_Tree_Ref) is
1290 Iter : Source_Iterator := For_Each_Source (Tree);
1291 Source : Prj.Source_Id;
1292 File : Text_File;
1293
1294 begin
1295 if Opt.Verbose_Mode then
1296 Write_Line ("Writing new source info file " &
1297 Tree.Source_Info_File_Name.all);
1298 end if;
1299
1300 Create (File, Tree.Source_Info_File_Name.all);
1301
1302 if not Is_Valid (File) then
1303 Write_Line ("warning: unable to create source info file """ &
1304 Tree.Source_Info_File_Name.all & '"');
1305 return;
1306 end if;
1307
1308 loop
1309 Source := Element (Iter);
1310 exit when Source = No_Source;
1311
1312 if not Source.Locally_Removed and then
1313 Source.Replaced_By = No_Source
1314 then
1315 -- Project name
1316
1317 Put_Line (File, Get_Name_String (Source.Project.Name));
1318
1319 -- Language name
1320
1321 Put_Line (File, Get_Name_String (Source.Language.Name));
1322
1323 -- Kind
1324
1325 Put_Line (File, Source.Kind'Img);
1326
1327 -- Display path name
1328
1329 Put_Line (File, Get_Name_String (Source.Path.Display_Name));
1330
1331 -- Optional lines:
1332
1333 -- Path name (P=)
1334
1335 if Source.Path.Name /= Source.Path.Display_Name then
1336 Put (File, "P=");
1337 Put_Line (File, Get_Name_String (Source.Path.Name));
1338 end if;
1339
1340 -- Unit name (U=)
1341
1342 if Source.Unit /= No_Unit_Index then
1343 Put (File, "U=");
1344 Put_Line (File, Get_Name_String (Source.Unit.Name));
1345 end if;
1346
1347 -- Multi-source index (I=)
1348
1349 if Source.Index /= 0 then
1350 Put (File, "I=");
1351 Put_Line (File, Source.Index'Img);
1352 end if;
1353
1354 -- Naming exception ("N=T");
1355
1356 if Source.Naming_Exception = Yes then
1357 Put_Line (File, "N=Y");
1358
1359 elsif Source.Naming_Exception = Inherited then
1360 Put_Line (File, "N=I");
1361 end if;
1362
1363 -- Empty line to indicate end of info on this source
1364
1365 Put_Line (File, "");
1366 end if;
1367
1368 Next (Iter);
1369 end loop;
1370
1371 Close (File);
1372 end Write_Source_Info_File;
1373
1374 ---------------
1375 -- Write_Str --
1376 ---------------
1377
1378 procedure Write_Str
1379 (S : String;
1380 Max_Length : Positive;
1381 Separator : Character)
1382 is
1383 First : Positive := S'First;
1384 Last : Natural := S'Last;
1385
1386 begin
1387 -- Nothing to do for empty strings
1388
1389 if S'Length > 0 then
1390
1391 -- Start on a new line if current line is already longer than
1392 -- Max_Length.
1393
1394 if Positive (Column) >= Max_Length then
1395 Write_Eol;
1396 end if;
1397
1398 -- If length of remainder is longer than Max_Length, we need to
1399 -- cut the remainder in several lines.
1400
1401 while Positive (Column) + S'Last - First > Max_Length loop
1402
1403 -- Try the maximum length possible
1404
1405 Last := First + Max_Length - Positive (Column);
1406
1407 -- Look for last Separator in the line
1408
1409 while Last >= First and then S (Last) /= Separator loop
1410 Last := Last - 1;
1411 end loop;
1412
1413 -- If we do not find a separator, output maximum length possible
1414
1415 if Last < First then
1416 Last := First + Max_Length - Positive (Column);
1417 end if;
1418
1419 Write_Line (S (First .. Last));
1420
1421 -- Set the beginning of the new remainder
1422
1423 First := Last + 1;
1424 end loop;
1425
1426 -- What is left goes to the buffer, without EOL
1427
1428 Write_Str (S (First .. S'Last));
1429 end if;
1430 end Write_Str;
1431
1432 end Prj.Util;