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