1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2015, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Ada.Containers.Indefinite_Ordered_Sets;
28 with Ada.Strings.Fixed; use Ada.Strings.Fixed;
29 with Ada.Strings.Maps; use Ada.Strings.Maps;
30 with Ada.Unchecked_Deallocation;
32 with GNAT.Case_Util; use GNAT.Case_Util;
33 with GNAT.Regexp; use GNAT.Regexp;
36 with Osint; use Osint;
37 with Output; use Output;
40 with Snames; use Snames;
42 with Targparm; use Targparm;
46 package body Prj.Util is
48 package Source_Info_Table is new Table.Table
49 (Table_Component_Type => Source_Info_Iterator,
50 Table_Index_Type => Natural,
53 Table_Increment => 100,
54 Table_Name => "Makeutl.Source_Info_Table");
56 package Source_Info_Project_HTable is new GNAT.HTable.Simple_HTable
57 (Header_Num => Prj.Header_Num,
64 procedure Free is new Ada.Unchecked_Deallocation
65 (Text_File_Data, Text_File);
71 procedure Close (File : in out Text_File) is
77 Prj.Com.Fail ("Close attempted on an invalid Text_File");
81 if File.Buffer_Len > 0 then
82 Len := Write (File.FD, File.Buffer'Address, File.Buffer_Len);
84 if Len /= File.Buffer_Len then
85 Prj.Com.Fail ("Unable to write to an out Text_File");
89 Close (File.FD, Status);
92 Prj.Com.Fail ("Unable to close an out Text_File");
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.
110 procedure Create (File : out Text_File; Name : String) is
111 FD : File_Descriptor;
112 File_Name : String (1 .. Name'Length + 1);
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);
120 if FD = Invalid_FD then
124 File := new Text_File_Data;
126 File.Out_File := True;
127 File.End_Of_File_Reached := True;
136 (This : in out Name_List_Index;
137 Shared : Shared_Project_Tree_Data_Access)
139 Old_Current : Name_List_Index;
140 New_Current : Name_List_Index;
143 if This /= No_Name_List then
145 Name_List_Table.Increment_Last (Shared.Name_Lists);
146 New_Current := Name_List_Table.Last (Shared.Name_Lists);
148 Shared.Name_Lists.Table (New_Current) :=
149 (Shared.Name_Lists.Table (Old_Current).Name, No_Name_List);
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);
167 function End_Of_File (File : Text_File) return Boolean is
170 Prj.Com.Fail ("End_Of_File attempted on an invalid Text_File");
173 return File.End_Of_File_Reached;
180 function Executable_Of
181 (Project : Project_Id;
182 Shared : Shared_Project_Tree_Data_Access;
183 Main : File_Name_Type;
185 Ada_Main : Boolean := True;
186 Language : String := "";
187 Include_Suffix : Boolean := True) return File_Name_Type
189 pragma Assert (Project /= No_Project);
191 The_Packages : constant Package_Id := Project.Decl.Packages;
193 Builder_Package : constant Prj.Package_Id :=
195 (Name => Name_Builder,
196 In_Packages => The_Packages,
199 Executable : Variable_Value :=
201 (Name => Name_Id (Main),
203 Attribute_Or_Array_Name => Name_Executable,
204 In_Package => Builder_Package,
209 Spec_Suffix : Name_Id := No_Name;
210 Body_Suffix : Name_Id := No_Name;
212 Spec_Suffix_Length : Natural := 0;
213 Body_Suffix_Length : Natural := 0;
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
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
228 procedure Get_Suffixes
229 (B_Suffix : File_Name_Type;
230 S_Suffix : File_Name_Type)
233 if B_Suffix /= No_File then
234 Body_Suffix := Name_Id (B_Suffix);
235 Body_Suffix_Length := Natural (Length_Of_Name (Body_Suffix));
238 if S_Suffix /= No_File then
239 Spec_Suffix := Name_Id (S_Suffix);
240 Spec_Suffix_Length := Natural (Length_Of_Name (Spec_Suffix));
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;
253 if Include_Suffix then
254 if Project.Config.Executable_Suffix /= No_Name then
255 Executable_Extension_On_Target :=
256 Project.Config.Executable_Suffix;
259 Result := Executable_Name (File);
260 Executable_Extension_On_Target := Saved_EEOT;
263 elsif Builder_Package /= No_Package then
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.
270 Suffix_From_Project :=
272 (Variable_Name => Name_Executable_Suffix,
274 Shared.Packages.Table (Builder_Package).Decl.Attributes,
277 if Suffix_From_Project /= Nil_Variable_Value
278 and then Suffix_From_Project.Value /= No_Name
280 Executable_Extension_On_Target := Suffix_From_Project.Value;
281 Result := Executable_Name (File);
282 Executable_Extension_On_Target := Saved_EEOT;
290 -- Start of processing for Executable_Of
294 Lang := Get_Language_From_Name (Project, "ada");
295 elsif Language /= "" then
296 Lang := Get_Language_From_Name (Project, Language);
301 (B_Suffix => Lang.Config.Naming_Data.Body_Suffix,
302 S_Suffix => Lang.Config.Naming_Data.Spec_Suffix);
305 if Builder_Package /= No_Package then
306 if Executable = Nil_Variable_Value and then Ada_Main then
307 Get_Name_String (Main);
309 -- Try as index the name minus the implementation suffix or minus
310 -- the specification suffix.
313 Name : constant String (1 .. Name_Len) :=
314 Name_Buffer (1 .. Name_Len);
315 Last : Positive := Name_Len;
317 Truncated : Boolean := False;
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)
326 Last := Last - Body_Suffix_Length;
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)
336 Last := Last - Spec_Suffix_Length;
341 Name_Buffer (1 .. Name_Len) := Name (1 .. Last);
346 Attribute_Or_Array_Name => Name_Executable,
347 In_Package => Builder_Package,
353 -- If we have found an Executable attribute, return its value,
354 -- possibly suffixed by the executable suffix.
356 if Executable /= Nil_Variable_Value
357 and then Executable.Value /= No_Name
358 and then Length_Of_Name (Executable.Value) /= 0
360 return Add_Suffix (File_Name_Type (Executable.Value));
364 Get_Name_String (Main);
366 -- If there is a body suffix or a spec suffix, remove this suffix,
367 -- otherwise remove any suffix ('.' followed by other characters), if
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)
375 -- Found the body termination, remove it
377 Name_Len := Name_Len - Body_Suffix_Length;
379 elsif Spec_Suffix /= No_Name
380 and then Name_Len > Spec_Suffix_Length
382 Name_Buffer (Name_Len - Spec_Suffix_Length + 1 .. Name_Len) =
383 Get_Name_String (Spec_Suffix)
385 -- Found the spec termination, remove it
387 Name_Len := Name_Len - Spec_Suffix_Length;
390 -- Remove any suffix, if there is one
392 Get_Name_String (Strip_Suffix (Main));
395 return Add_Suffix (Name_Find);
398 ---------------------------
399 -- For_Interface_Sources --
400 ---------------------------
402 procedure For_Interface_Sources
403 (Tree : Project_Tree_Ref;
404 Project : Project_Id)
407 use type Ada.Containers.Count_Type;
409 package Dep_Names is new Containers.Indefinite_Ordered_Sets (String);
411 function Load_ALI (Filename : String) return ALI_Id;
412 -- Load an ALI file and return its id
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;
424 if Directories.Exists (Filename) then
426 Add_Str_To_Name_Buffer (Filename);
427 Lib_File := Name_Find;
428 Text := Osint.Read_Library_Info (Lib_File);
442 -- Local declarations
444 Iter : Source_Iterator;
448 First_Unit : Unit_Id;
449 Second_Unit : Unit_Id;
450 Body_Needed : Boolean;
451 Deps : Dep_Names.Set;
453 -- Start of processing for For_Interface_Sources
456 if Project.Qualifier = Aggregate_Library then
457 Iter := For_Each_Source (Tree);
459 Iter := For_Each_Source (Tree, Project);
462 -- First look at each spec, check if the body is needed
465 Sid := Element (Iter);
466 exit when Sid = No_Source;
468 -- Skip sources that are removed/excluded and sources not part of
469 -- the interface for standalone libraries.
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)
478 -- Handle case of non-compilable languages
480 and then Sid.Dep_Name /= No_File
484 -- Check ALI for dependencies on body and sep
488 (Get_Name_String (Get_Object_Directory (Sid.Project, True))
489 & Get_Name_String (Sid.Dep_Name));
491 if ALI /= No_ALI_Id then
492 First_Unit := ALIs.Table (ALI).First_Unit;
493 Second_Unit := No_Unit_Id;
496 -- If there is both a spec and a body, check if both needed
498 if Units.Table (First_Unit).Utype = Is_Body then
499 Second_Unit := ALIs.Table (ALI).Last_Unit;
501 -- If the body is not needed, then reset First_Unit
503 if not Units.Table (Second_Unit).Body_Needed_For_SAL then
504 Body_Needed := False;
507 elsif Units.Table (First_Unit).Utype = Is_Spec_Only then
508 Body_Needed := False;
511 -- Handle all the separates, if any
514 if Other_Part (Sid) /= null then
515 Deps.Include (Get_Name_String (Other_Part (Sid).File));
518 for Dep in ALIs.Table (ALI).First_Sdep ..
519 ALIs.Table (ALI).Last_Sdep
521 if Sdep.Table (Dep).Subunit_Name /= No_Name then
523 (Get_Name_String (Sdep.Table (Dep).Sfile));
533 -- Now handle the bodies and separates if needed
535 if Deps.Length /= 0 then
536 if Project.Qualifier = Aggregate_Library then
537 Iter := For_Each_Source (Tree);
539 Iter := For_Each_Source (Tree, Project);
543 Sid := Element (Iter);
544 exit when Sid = No_Source;
547 and then Deps.Contains (Get_Name_String (Sid.File))
555 end For_Interface_Sources;
576 if File.Cursor = File.Buffer_Len then
580 A => File.Buffer'Address,
581 N => File.Buffer'Length);
583 if File.Buffer_Len = 0 then
584 File.End_Of_File_Reached := True;
591 File.Cursor := File.Cursor + 1;
595 -- Start of processing for Get_Line
599 Prj.Com.Fail ("Get_Line attempted on an invalid Text_File");
601 elsif File.Out_File then
602 Prj.Com.Fail ("Get_Line attempted on an out file");
605 Last := Line'First - 1;
607 if not File.End_Of_File_Reached then
609 C := File.Buffer (File.Cursor);
610 exit when C = ASCII.CR or else C = ASCII.LF;
615 if File.End_Of_File_Reached then
619 exit when Last = Line'Last;
622 if C = ASCII.CR or else C = ASCII.LF then
625 if File.End_Of_File_Reached then
631 and then File.Buffer (File.Cursor) = ASCII.LF
643 (Iter : out Source_Info_Iterator;
644 For_Project : Name_Id)
646 Ind : constant Natural := Source_Info_Project_HTable.Get (For_Project);
649 Iter := (No_Source_Info, 0);
651 Iter := Source_Info_Table.Table (Ind);
659 function Is_Valid (File : Text_File) return Boolean is
668 procedure Next (Iter : in out Source_Info_Iterator) is
670 if Iter.Next = 0 then
671 Iter.Info := No_Source_Info;
674 Iter := Source_Info_Table.Table (Iter.Next);
682 procedure Open (File : out Text_File; Name : String) is
683 FD : File_Descriptor;
684 File_Name : String (1 .. Name'Length + 1);
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);
692 if FD = Invalid_FD then
696 File := new Text_File_Data;
700 A => File.Buffer'Address,
701 N => File.Buffer'Length);
703 if File.Buffer_Len = 0 then
704 File.End_Of_File_Reached := True;
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)
721 Shared : constant Shared_Project_Tree_Data_Access := In_Tree.Shared;
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);
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
735 Current_Name := Shared.Name_Lists.Table (Current_Name).Next;
739 while List /= Nil_String loop
740 Element := Shared.String_Elements.Table (List);
741 Value := Element.Value;
744 Get_Name_String (Value);
745 To_Lower (Name_Buffer (1 .. Name_Len));
749 Name_List_Table.Append
750 (Shared.Name_Lists, (Name => Value, Next => No_Name_List));
754 if Current_Name = No_Name_List then
757 Shared.Name_Lists.Table (Current_Name).Next := Last;
760 Current_Name := Last;
762 List := Element.Next;
766 procedure Put (File : Text_File; S : String) is
770 Prj.Com.Fail ("Attempted to write on an invalid Text_File");
772 elsif not File.Out_File then
773 Prj.Com.Fail ("Attempted to write an in Text_File");
776 if File.Buffer_Len + S'Length > File.Buffer'Last then
778 Len := Write (File.FD, File.Buffer'Address, File.Buffer_Len);
780 if Len /= File.Buffer_Len then
781 Prj.Com.Fail ("Failed to write to an out Text_File");
784 File.Buffer_Len := 0;
787 File.Buffer (File.Buffer_Len + 1 .. File.Buffer_Len + S'Length) := S;
788 File.Buffer_Len := File.Buffer_Len + S'Length;
795 procedure Put_Line (File : Text_File; Line : String) is
796 L : String (1 .. Line'Length + 1);
798 L (1 .. Line'Length) := Line;
799 L (L'Last) := ASCII.LF;
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
811 ----------------------
812 -- Ensure_Directory --
813 ----------------------
815 function Ensure_Directory (Path : String) return String is
818 or else Path (Path'Last) = Directory_Separator
819 or else Path (Path'Last) = '/' -- on Windows check also for /
823 return Path & Directory_Separator;
825 end Ensure_Directory;
829 Dir_Sep_Map : constant Character_Mapping := To_Mapping ("\", "/");
831 P : String (1 .. Pathname'Length) := Pathname;
832 T : String (1 .. To'Length) := To;
834 Pi : Natural; -- common prefix ending
837 -- Start of processing for Relative_Path
840 pragma Assert (Is_Absolute_Path (Pathname));
841 pragma Assert (Is_Absolute_Path (To));
843 -- Use canonical directory separator
845 Translate (Source => P, Mapping => Dir_Sep_Map);
846 Translate (Source => T, Mapping => Dir_Sep_Map);
848 -- First check for common prefix
851 while Pi < P'Last and then Pi < T'Last and then P (Pi) = T (Pi) loop
855 -- Cut common prefix at a directory separator
857 while Pi > P'First and then P (Pi) /= '/' loop
861 -- Count directory under prefix in P, these will be replaced by the
862 -- corresponding number of "..".
864 N := Count (T (Pi + 1 .. T'Last), "/");
866 if T (T'Last) /= '/' then
870 return N * "../" & Ensure_Directory (P (Pi + 1 .. P'Last));
873 ---------------------------
874 -- Read_Source_Info_File --
875 ---------------------------
877 procedure Read_Source_Info_File (Tree : Project_Tree_Ref) is
879 Info : Source_Info_Iterator;
882 procedure Report_Error;
888 procedure Report_Error is
890 Write_Line ("errors in source info file """ &
891 Tree.Source_Info_File_Name.all & '"');
892 Tree.Source_Info_File_Exists := False;
896 Source_Info_Project_HTable.Reset;
897 Source_Info_Table.Init;
899 if Tree.Source_Info_File_Name = null then
900 Tree.Source_Info_File_Exists := False;
904 Open (File, Tree.Source_Info_File_Name.all);
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 &
912 Tree.Source_Info_File_Exists := False;
916 Tree.Source_Info_File_Exists := True;
918 if Opt.Verbose_Mode then
919 Write_Line ("Reading source info file " &
920 Tree.Source_Info_File_Name.all);
924 while not End_Of_File (File) loop
925 Info := (new Source_Info_Data, 0);
926 Source_Info_Table.Increment_Last;
929 Get_Line (File, Name_Buffer, Name_Len);
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);
935 if End_Of_File (File) then
941 Get_Line (File, Name_Buffer, Name_Len);
942 Info.Info.Language := Name_Find;
944 if End_Of_File (File) then
950 Get_Line (File, Name_Buffer, Name_Len);
951 Info.Info.Kind := Source_Kind'Value (Name_Buffer (1 .. Name_Len));
953 if End_Of_File (File) then
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;
963 if End_Of_File (File) then
971 Get_Line (File, Name_Buffer, Name_Len);
972 exit Option_Loop when Name_Len = 0;
974 if Name_Len <= 2 then
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;
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;
991 elsif Name_Buffer (1 .. 2) = "I=" then
992 Info.Info.Index := Int'Value (Name_Buffer (3 .. Name_Len));
994 elsif Name_Buffer (1 .. Name_Len) = "N=Y" then
995 Info.Info.Naming_Exception := Yes;
997 elsif Name_Buffer (1 .. Name_Len) = "N=I" then
998 Info.Info.Naming_Exception := Inherited;
1005 end loop Option_Loop;
1007 Source_Info_Table.Table (Source_Info_Table.Last) := Info;
1008 end loop Source_Loop;
1016 end Read_Source_Info_File;
1018 --------------------
1019 -- Source_Info_Of --
1020 --------------------
1022 function Source_Info_Of (Iter : Source_Info_Iterator) return Source_Info is
1032 (Variable : Variable_Value;
1033 Default : String) return String
1036 if Variable.Kind /= Single
1037 or else Variable.Default
1038 or else Variable.Value = No_Name
1042 return Get_Name_String (Variable.Value);
1048 In_Array : Array_Element_Id;
1049 Shared : Shared_Project_Tree_Data_Access) return Name_Id
1052 Current : Array_Element_Id;
1053 Element : Array_Element;
1054 Real_Index : Name_Id := Index;
1057 Current := In_Array;
1059 if Current = No_Array_Element then
1063 Element := Shared.Array_Elements.Table (Current);
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;
1071 while Current /= No_Array_Element loop
1072 Element := Shared.Array_Elements.Table (Current);
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;
1079 Current := Element.Next;
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
1094 Current : Array_Element_Id;
1095 Element : Array_Element;
1096 Real_Index_1 : Name_Id;
1097 Real_Index_2 : Name_Id;
1100 Current := In_Array;
1102 if Current = No_Array_Element then
1103 return Nil_Variable_Value;
1106 Element := Shared.Array_Elements.Table (Current);
1108 Real_Index_1 := Index;
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;
1118 while Current /= No_Array_Element loop
1119 Element := Shared.Array_Elements.Table (Current);
1120 Real_Index_2 := Element.Index;
1122 if not Element.Index_Case_Sensitive
1123 or else Force_Lower_Case_Index
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;
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),
1140 return Element.Value;
1142 Current := Element.Next;
1146 return Nil_Variable_Value;
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
1158 The_Array : Array_Element_Id;
1159 The_Attribute : Variable_Value := Nil_Variable_Value;
1162 if In_Package /= No_Package then
1164 -- First, look if there is an array element that fits
1168 (Name => Attribute_Or_Array_Name,
1169 In_Arrays => Shared.Packages.Table (In_Package).Decl.Arrays,
1175 In_Array => The_Array,
1177 Force_Lower_Case_Index => Force_Lower_Case_Index,
1178 Allow_Wildcards => Allow_Wildcards);
1180 -- If there is no array element, look for a variable
1182 if The_Attribute = Nil_Variable_Value then
1185 (Variable_Name => Attribute_Or_Array_Name,
1186 In_Variables => Shared.Packages.Table
1187 (In_Package).Decl.Attributes,
1192 return The_Attribute;
1198 In_Arrays : Array_Id;
1199 Shared : Shared_Project_Tree_Data_Access) return Name_Id
1202 The_Array : Array_Data;
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
1210 (Index, In_Array => The_Array.Value, Shared => Shared);
1212 Current := The_Array.Next;
1221 In_Arrays : Array_Id;
1222 Shared : Shared_Project_Tree_Data_Access) return Array_Element_Id
1225 The_Array : Array_Data;
1228 Current := In_Arrays;
1229 while Current /= No_Array loop
1230 The_Array := Shared.Arrays.Table (Current);
1232 if The_Array.Name = Name then
1233 return The_Array.Value;
1235 Current := The_Array.Next;
1239 return No_Array_Element;
1244 In_Packages : Package_Id;
1245 Shared : Shared_Project_Tree_Data_Access) return Package_Id
1247 Current : Package_Id;
1248 The_Package : Package_Element;
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;
1263 (Variable_Name : Name_Id;
1264 In_Variables : Variable_Id;
1265 Shared : Shared_Project_Tree_Data_Access) return Variable_Value
1267 Current : Variable_Id;
1268 The_Variable : Variable;
1271 Current := In_Variables;
1272 while Current /= No_Variable loop
1273 The_Variable := Shared.Variable_Elements.Table (Current);
1275 if Variable_Name = The_Variable.Name then
1276 return The_Variable.Value;
1278 Current := The_Variable.Next;
1282 return Nil_Variable_Value;
1285 ----------------------------
1286 -- Write_Source_Info_File --
1287 ----------------------------
1289 procedure Write_Source_Info_File (Tree : Project_Tree_Ref) is
1290 Iter : Source_Iterator := For_Each_Source (Tree);
1291 Source : Prj.Source_Id;
1295 if Opt.Verbose_Mode then
1296 Write_Line ("Writing new source info file " &
1297 Tree.Source_Info_File_Name.all);
1300 Create (File, Tree.Source_Info_File_Name.all);
1302 if not Is_Valid (File) then
1303 Write_Line ("warning: unable to create source info file """ &
1304 Tree.Source_Info_File_Name.all & '"');
1309 Source := Element (Iter);
1310 exit when Source = No_Source;
1312 if not Source.Locally_Removed and then
1313 Source.Replaced_By = No_Source
1317 Put_Line (File, Get_Name_String (Source.Project.Name));
1321 Put_Line (File, Get_Name_String (Source.Language.Name));
1325 Put_Line (File, Source.Kind'Img);
1327 -- Display path name
1329 Put_Line (File, Get_Name_String (Source.Path.Display_Name));
1335 if Source.Path.Name /= Source.Path.Display_Name then
1337 Put_Line (File, Get_Name_String (Source.Path.Name));
1342 if Source.Unit /= No_Unit_Index then
1344 Put_Line (File, Get_Name_String (Source.Unit.Name));
1347 -- Multi-source index (I=)
1349 if Source.Index /= 0 then
1351 Put_Line (File, Source.Index'Img);
1354 -- Naming exception ("N=T");
1356 if Source.Naming_Exception = Yes then
1357 Put_Line (File, "N=Y");
1359 elsif Source.Naming_Exception = Inherited then
1360 Put_Line (File, "N=I");
1363 -- Empty line to indicate end of info on this source
1365 Put_Line (File, "");
1372 end Write_Source_Info_File;
1380 Max_Length : Positive;
1381 Separator : Character)
1383 First : Positive := S'First;
1384 Last : Natural := S'Last;
1387 -- Nothing to do for empty strings
1389 if S'Length > 0 then
1391 -- Start on a new line if current line is already longer than
1394 if Positive (Column) >= Max_Length then
1398 -- If length of remainder is longer than Max_Length, we need to
1399 -- cut the remainder in several lines.
1401 while Positive (Column) + S'Last - First > Max_Length loop
1403 -- Try the maximum length possible
1405 Last := First + Max_Length - Positive (Column);
1407 -- Look for last Separator in the line
1409 while Last >= First and then S (Last) /= Separator loop
1413 -- If we do not find a separator, output maximum length possible
1415 if Last < First then
1416 Last := First + Max_Length - Positive (Column);
1419 Write_Line (S (First .. Last));
1421 -- Set the beginning of the new remainder
1426 -- What is left goes to the buffer, without EOL
1428 Write_Str (S (First .. S'Last));