1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2009, 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
.Unchecked_Deallocation
;
28 with GNAT
.Case_Util
; use GNAT
.Case_Util
;
30 with Osint
; use Osint
;
31 with Output
; use Output
;
33 with Snames
; use Snames
;
34 with Targparm
; use Targparm
;
36 package body Prj
.Util
is
38 procedure Free
is new Ada
.Unchecked_Deallocation
39 (Text_File_Data
, Text_File
);
45 procedure Close
(File
: in out Text_File
) is
48 Prj
.Com
.Fail
("Close attempted on an invalid Text_File");
51 -- Close file, no need to test status, since this is a file that we
52 -- read, and the file was read successfully before we closed it.
63 (This
: in out Name_List_Index
;
64 In_Tree
: Project_Tree_Ref
)
66 Old_Current
: Name_List_Index
;
67 New_Current
: Name_List_Index
;
70 if This
/= No_Name_List
then
72 Name_List_Table
.Increment_Last
(In_Tree
.Name_Lists
);
73 New_Current
:= Name_List_Table
.Last
(In_Tree
.Name_Lists
);
75 In_Tree
.Name_Lists
.Table
(New_Current
) :=
76 (In_Tree
.Name_Lists
.Table
(Old_Current
).Name
, No_Name_List
);
79 Old_Current
:= In_Tree
.Name_Lists
.Table
(Old_Current
).Next
;
80 exit when Old_Current
= No_Name_List
;
81 In_Tree
.Name_Lists
.Table
(New_Current
).Next
:= New_Current
+ 1;
82 Name_List_Table
.Increment_Last
(In_Tree
.Name_Lists
);
83 New_Current
:= New_Current
+ 1;
84 In_Tree
.Name_Lists
.Table
(New_Current
) :=
85 (In_Tree
.Name_Lists
.Table
(Old_Current
).Name
, No_Name_List
);
94 function End_Of_File
(File
: Text_File
) return Boolean is
97 Prj
.Com
.Fail
("End_Of_File attempted on an invalid Text_File");
100 return File
.End_Of_File_Reached
;
107 function Executable_Of
108 (Project
: Project_Id
;
109 In_Tree
: Project_Tree_Ref
;
110 Main
: File_Name_Type
;
112 Ada_Main
: Boolean := True;
113 Language
: String := "") return File_Name_Type
115 pragma Assert
(Project
/= No_Project
);
117 The_Packages
: constant Package_Id
:= Project
.Decl
.Packages
;
119 Builder_Package
: constant Prj
.Package_Id
:=
121 (Name
=> Name_Builder
,
122 In_Packages
=> The_Packages
,
125 Executable
: Variable_Value
:=
127 (Name
=> Name_Id
(Main
),
129 Attribute_Or_Array_Name
=> Name_Executable
,
130 In_Package
=> Builder_Package
,
133 Executable_Suffix_Name
: Name_Id
:= No_Name
;
137 Spec_Suffix
: Name_Id
:= No_Name
;
138 Body_Suffix
: Name_Id
:= No_Name
;
140 Spec_Suffix_Length
: Natural := 0;
141 Body_Suffix_Length
: Natural := 0;
143 procedure Get_Suffixes
144 (B_Suffix
: File_Name_Type
;
145 S_Suffix
: File_Name_Type
);
146 -- Get the non empty suffixes in variables Spec_Suffix and Body_Suffix
152 procedure Get_Suffixes
153 (B_Suffix
: File_Name_Type
;
154 S_Suffix
: File_Name_Type
)
157 if B_Suffix
/= No_File
then
158 Body_Suffix
:= Name_Id
(B_Suffix
);
159 Body_Suffix_Length
:= Natural (Length_Of_Name
(Body_Suffix
));
162 if S_Suffix
/= No_File
then
163 Spec_Suffix
:= Name_Id
(S_Suffix
);
164 Spec_Suffix_Length
:= Natural (Length_Of_Name
(Spec_Suffix
));
168 -- Start of processing for Executable_Of
172 Lang
:= Get_Language_From_Name
(Project
, "ada");
173 elsif Language
/= "" then
174 Lang
:= Get_Language_From_Name
(Project
, Language
);
179 (B_Suffix
=> Lang
.Config
.Naming_Data
.Body_Suffix
,
180 S_Suffix
=> Lang
.Config
.Naming_Data
.Spec_Suffix
);
183 if Builder_Package
/= No_Package
then
184 Executable_Suffix_Name
:= Project
.Config
.Executable_Suffix
;
186 if Executable
= Nil_Variable_Value
and then Ada_Main
then
187 Get_Name_String
(Main
);
189 -- Try as index the name minus the implementation suffix or minus
190 -- the specification suffix.
193 Name
: constant String (1 .. Name_Len
) :=
194 Name_Buffer
(1 .. Name_Len
);
195 Last
: Positive := Name_Len
;
197 Truncated
: Boolean := False;
200 if Body_Suffix
/= No_Name
201 and then Last
> Natural (Length_Of_Name
(Body_Suffix
))
202 and then Name
(Last
- Body_Suffix_Length
+ 1 .. Last
) =
203 Get_Name_String
(Body_Suffix
)
206 Last
:= Last
- Body_Suffix_Length
;
209 if Spec_Suffix
/= No_Name
210 and then not Truncated
211 and then Last
> Spec_Suffix_Length
212 and then Name
(Last
- Spec_Suffix_Length
+ 1 .. Last
) =
213 Get_Name_String
(Spec_Suffix
)
216 Last
:= Last
- Spec_Suffix_Length
;
221 Name_Buffer
(1 .. Name_Len
) := Name
(1 .. Last
);
226 Attribute_Or_Array_Name
=> Name_Executable
,
227 In_Package
=> Builder_Package
,
233 -- If we have found an Executable attribute, return its value,
234 -- possibly suffixed by the executable suffix.
236 if Executable
/= Nil_Variable_Value
237 and then Executable
.Value
/= No_Name
238 and then Length_Of_Name
(Executable
.Value
) /= 0
240 -- Get the executable name. If Executable_Suffix is defined,
241 -- make sure that it will be the extension of the executable.
244 Saved_EEOT
: constant Name_Id
:= Executable_Extension_On_Target
;
245 Result
: File_Name_Type
;
248 if Executable_Suffix_Name
/= No_Name
then
249 Executable_Extension_On_Target
:= Executable_Suffix_Name
;
252 Result
:= Executable_Name
(File_Name_Type
(Executable
.Value
));
253 Executable_Extension_On_Target
:= Saved_EEOT
;
259 Get_Name_String
(Main
);
261 -- If there is a body suffix or a spec suffix, remove this suffix,
262 -- otherwise remove any suffix ('.' followed by other characters), if
265 if Body_Suffix
/= No_Name
266 and then Name_Len
> Body_Suffix_Length
267 and then Name_Buffer
(Name_Len
- Body_Suffix_Length
+ 1 .. Name_Len
) =
268 Get_Name_String
(Body_Suffix
)
270 -- Found the body termination, remove it
272 Name_Len
:= Name_Len
- Body_Suffix_Length
;
274 elsif Spec_Suffix
/= No_Name
275 and then Name_Len
> Spec_Suffix_Length
277 Name_Buffer
(Name_Len
- Spec_Suffix_Length
+ 1 .. Name_Len
) =
278 Get_Name_String
(Spec_Suffix
)
280 -- Found the spec termination, remove it
282 Name_Len
:= Name_Len
- Spec_Suffix_Length
;
285 -- Remove any suffix, if there is one
287 Get_Name_String
(Strip_Suffix
(Main
));
290 -- Get the executable name. If Executable_Suffix is defined in the
291 -- configuration, make sure that it will be the extension of the
295 Saved_EEOT
: constant Name_Id
:= Executable_Extension_On_Target
;
296 Result
: File_Name_Type
;
299 if Project
.Config
.Executable_Suffix
/= No_Name
then
300 Executable_Extension_On_Target
:=
301 Project
.Config
.Executable_Suffix
;
304 Result
:= Executable_Name
(Name_Find
);
305 Executable_Extension_On_Target
:= Saved_EEOT
;
329 if File
.Cursor
= File
.Buffer_Len
then
333 A
=> File
.Buffer
'Address,
334 N
=> File
.Buffer
'Length);
336 if File
.Buffer_Len
= 0 then
337 File
.End_Of_File_Reached
:= True;
344 File
.Cursor
:= File
.Cursor
+ 1;
348 -- Start of processing for Get_Line
352 Prj
.Com
.Fail
("Get_Line attempted on an invalid Text_File");
355 Last
:= Line
'First - 1;
357 if not File
.End_Of_File_Reached
then
359 C
:= File
.Buffer
(File
.Cursor
);
360 exit when C
= ASCII
.CR
or else C
= ASCII
.LF
;
365 if File
.End_Of_File_Reached
then
369 exit when Last
= Line
'Last;
372 if C
= ASCII
.CR
or else C
= ASCII
.LF
then
375 if File
.End_Of_File_Reached
then
381 and then File
.Buffer
(File
.Cursor
) = ASCII
.LF
392 function Is_Valid
(File
: Text_File
) return Boolean is
401 procedure Open
(File
: out Text_File
; Name
: String) is
402 FD
: File_Descriptor
;
403 File_Name
: String (1 .. Name
'Length + 1);
406 File_Name
(1 .. Name
'Length) := Name
;
407 File_Name
(File_Name
'Last) := ASCII
.NUL
;
408 FD
:= Open_Read
(Name
=> File_Name
'Address,
409 Fmode
=> GNAT
.OS_Lib
.Text
);
411 if FD
= Invalid_FD
then
415 File
:= new Text_File_Data
;
419 A
=> File
.Buffer
'Address,
420 N
=> File
.Buffer
'Length);
422 if File
.Buffer_Len
= 0 then
423 File
.End_Of_File_Reached
:= True;
435 (Into_List
: in out Name_List_Index
;
436 From_List
: String_List_Id
;
437 In_Tree
: Project_Tree_Ref
;
438 Lower_Case
: Boolean := False)
440 Current_Name
: Name_List_Index
;
441 List
: String_List_Id
;
442 Element
: String_Element
;
443 Last
: Name_List_Index
:=
444 Name_List_Table
.Last
(In_Tree
.Name_Lists
);
448 Current_Name
:= Into_List
;
449 while Current_Name
/= No_Name_List
450 and then In_Tree
.Name_Lists
.Table
(Current_Name
).Next
/= No_Name_List
452 Current_Name
:= In_Tree
.Name_Lists
.Table
(Current_Name
).Next
;
456 while List
/= Nil_String
loop
457 Element
:= In_Tree
.String_Elements
.Table
(List
);
458 Value
:= Element
.Value
;
461 Get_Name_String
(Value
);
462 To_Lower
(Name_Buffer
(1 .. Name_Len
));
466 Name_List_Table
.Append
467 (In_Tree
.Name_Lists
, (Name
=> Value
, Next
=> No_Name_List
));
471 if Current_Name
= No_Name_List
then
475 In_Tree
.Name_Lists
.Table
(Current_Name
).Next
:= Last
;
478 Current_Name
:= Last
;
480 List
:= Element
.Next
;
489 (Variable
: Variable_Value
;
490 Default
: String) return String
493 if Variable
.Kind
/= Single
494 or else Variable
.Default
495 or else Variable
.Value
= No_Name
499 return Get_Name_String
(Variable
.Value
);
505 In_Array
: Array_Element_Id
;
506 In_Tree
: Project_Tree_Ref
) return Name_Id
508 Current
: Array_Element_Id
;
509 Element
: Array_Element
;
510 Real_Index
: Name_Id
:= Index
;
515 if Current
= No_Array_Element
then
519 Element
:= In_Tree
.Array_Elements
.Table
(Current
);
521 if not Element
.Index_Case_Sensitive
then
522 Get_Name_String
(Index
);
523 To_Lower
(Name_Buffer
(1 .. Name_Len
));
524 Real_Index
:= Name_Find
;
527 while Current
/= No_Array_Element
loop
528 Element
:= In_Tree
.Array_Elements
.Table
(Current
);
530 if Real_Index
= Element
.Index
then
531 exit when Element
.Value
.Kind
/= Single
;
532 exit when Element
.Value
.Value
= Empty_String
;
533 return Element
.Value
.Value
;
535 Current
:= Element
.Next
;
544 Src_Index
: Int
:= 0;
545 In_Array
: Array_Element_Id
;
546 In_Tree
: Project_Tree_Ref
;
547 Force_Lower_Case_Index
: Boolean := False) return Variable_Value
549 Current
: Array_Element_Id
;
550 Element
: Array_Element
;
551 Real_Index_1
: Name_Id
;
552 Real_Index_2
: Name_Id
;
557 if Current
= No_Array_Element
then
558 return Nil_Variable_Value
;
561 Element
:= In_Tree
.Array_Elements
.Table
(Current
);
563 Real_Index_1
:= Index
;
565 if not Element
.Index_Case_Sensitive
or else Force_Lower_Case_Index
then
566 if Index
/= All_Other_Names
then
567 Get_Name_String
(Index
);
568 To_Lower
(Name_Buffer
(1 .. Name_Len
));
569 Real_Index_1
:= Name_Find
;
573 while Current
/= No_Array_Element
loop
574 Element
:= In_Tree
.Array_Elements
.Table
(Current
);
575 Real_Index_2
:= Element
.Index
;
577 if not Element
.Index_Case_Sensitive
578 or else Force_Lower_Case_Index
580 if Element
.Index
/= All_Other_Names
then
581 Get_Name_String
(Element
.Index
);
582 To_Lower
(Name_Buffer
(1 .. Name_Len
));
583 Real_Index_2
:= Name_Find
;
587 if Real_Index_1
= Real_Index_2
and then
588 Src_Index
= Element
.Src_Index
590 return Element
.Value
;
592 Current
:= Element
.Next
;
596 return Nil_Variable_Value
;
602 Attribute_Or_Array_Name
: Name_Id
;
603 In_Package
: Package_Id
;
604 In_Tree
: Project_Tree_Ref
;
605 Force_Lower_Case_Index
: Boolean := False) return Variable_Value
607 The_Array
: Array_Element_Id
;
608 The_Attribute
: Variable_Value
:= Nil_Variable_Value
;
611 if In_Package
/= No_Package
then
613 -- First, look if there is an array element that fits
617 (Name
=> Attribute_Or_Array_Name
,
618 In_Arrays
=> In_Tree
.Packages
.Table
(In_Package
).Decl
.Arrays
,
624 In_Array
=> The_Array
,
626 Force_Lower_Case_Index
=> Force_Lower_Case_Index
);
628 -- If there is no array element, look for a variable
630 if The_Attribute
= Nil_Variable_Value
then
633 (Variable_Name
=> Attribute_Or_Array_Name
,
634 In_Variables
=> In_Tree
.Packages
.Table
635 (In_Package
).Decl
.Attributes
,
640 return The_Attribute
;
646 In_Arrays
: Array_Id
;
647 In_Tree
: Project_Tree_Ref
) return Name_Id
650 The_Array
: Array_Data
;
653 Current
:= In_Arrays
;
654 while Current
/= No_Array
loop
655 The_Array
:= In_Tree
.Arrays
.Table
(Current
);
656 if The_Array
.Name
= In_Array
then
658 (Index
, In_Array
=> The_Array
.Value
, In_Tree
=> In_Tree
);
660 Current
:= The_Array
.Next
;
669 In_Arrays
: Array_Id
;
670 In_Tree
: Project_Tree_Ref
) return Array_Element_Id
673 The_Array
: Array_Data
;
676 Current
:= In_Arrays
;
677 while Current
/= No_Array
loop
678 The_Array
:= In_Tree
.Arrays
.Table
(Current
);
680 if The_Array
.Name
= Name
then
681 return The_Array
.Value
;
683 Current
:= The_Array
.Next
;
687 return No_Array_Element
;
692 In_Packages
: Package_Id
;
693 In_Tree
: Project_Tree_Ref
) return Package_Id
695 Current
: Package_Id
;
696 The_Package
: Package_Element
;
699 Current
:= In_Packages
;
700 while Current
/= No_Package
loop
701 The_Package
:= In_Tree
.Packages
.Table
(Current
);
702 exit when The_Package
.Name
/= No_Name
703 and then The_Package
.Name
= Name
;
704 Current
:= The_Package
.Next
;
711 (Variable_Name
: Name_Id
;
712 In_Variables
: Variable_Id
;
713 In_Tree
: Project_Tree_Ref
) return Variable_Value
715 Current
: Variable_Id
;
716 The_Variable
: Variable
;
719 Current
:= In_Variables
;
720 while Current
/= No_Variable
loop
722 In_Tree
.Variable_Elements
.Table
(Current
);
724 if Variable_Name
= The_Variable
.Name
then
725 return The_Variable
.Value
;
727 Current
:= The_Variable
.Next
;
731 return Nil_Variable_Value
;
740 Max_Length
: Positive;
741 Separator
: Character)
743 First
: Positive := S
'First;
744 Last
: Natural := S
'Last;
747 -- Nothing to do for empty strings
751 -- Start on a new line if current line is already longer than
754 if Positive (Column
) >= Max_Length
then
758 -- If length of remainder is longer than Max_Length, we need to
759 -- cut the remainder in several lines.
761 while Positive (Column
) + S
'Last - First
> Max_Length
loop
763 -- Try the maximum length possible
765 Last
:= First
+ Max_Length
- Positive (Column
);
767 -- Look for last Separator in the line
769 while Last
>= First
and then S
(Last
) /= Separator
loop
773 -- If we do not find a separator, we output the maximum length
777 Last
:= First
+ Max_Length
- Positive (Column
);
780 Write_Line
(S
(First
.. Last
));
782 -- Set the beginning of the new remainder
787 -- What is left goes to the buffer, without EOL
789 Write_Str
(S
(First
.. S
'Last));