1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2006, 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Ada
.Unchecked_Deallocation
;
29 with GNAT
.Case_Util
; use GNAT
.Case_Util
;
31 with Namet
; use Namet
;
32 with Osint
; use Osint
;
33 with Output
; use Output
;
35 with Snames
; use Snames
;
36 with Targparm
; use Targparm
;
38 package body Prj
.Util
is
40 procedure Free
is new Ada
.Unchecked_Deallocation
41 (Text_File_Data
, Text_File
);
47 procedure Close
(File
: in out Text_File
) is
50 Prj
.Com
.Fail
("Close attempted on an invalid Text_File");
53 -- Close file, no need to test status, since this is a file that we
54 -- read, and the file was read successfully before we closed it.
64 function End_Of_File
(File
: Text_File
) return Boolean is
67 Prj
.Com
.Fail
("End_Of_File attempted on an invalid Text_File");
70 return File
.End_Of_File_Reached
;
77 function Executable_Of
78 (Project
: Project_Id
;
79 In_Tree
: Project_Tree_Ref
;
82 Ada_Main
: Boolean := True) return Name_Id
84 pragma Assert
(Project
/= No_Project
);
86 The_Packages
: constant Package_Id
:=
87 In_Tree
.Projects
.Table
(Project
).Decl
.Packages
;
89 Builder_Package
: constant Prj
.Package_Id
:=
91 (Name
=> Name_Builder
,
92 In_Packages
=> The_Packages
,
95 Executable
: Variable_Value
:=
99 Attribute_Or_Array_Name
=> Name_Executable
,
100 In_Package
=> Builder_Package
,
103 Executable_Suffix
: Variable_Value
:= Nil_Variable_Value
;
105 Body_Append
: constant String := Get_Name_String
106 (In_Tree
.Projects
.Table
108 Naming
.Ada_Body_Suffix
);
110 Spec_Append
: constant String := Get_Name_String
111 (In_Tree
.Projects
.Table
113 Naming
.Ada_Spec_Suffix
);
116 if Builder_Package
/= No_Package
then
117 Executable_Suffix
:= Prj
.Util
.Value_Of
118 (Variable_Name
=> Name_Executable_Suffix
,
119 In_Variables
=> In_Tree
.Packages
.Table
120 (Builder_Package
).Decl
.Attributes
,
123 if Executable
= Nil_Variable_Value
and Ada_Main
then
124 Get_Name_String
(Main
);
126 -- Try as index the name minus the implementation suffix or minus
127 -- the specification suffix.
130 Name
: constant String (1 .. Name_Len
) :=
131 Name_Buffer
(1 .. Name_Len
);
132 Last
: Positive := Name_Len
;
134 Naming
: constant Naming_Data
:=
135 In_Tree
.Projects
.Table
(Project
).Naming
;
137 Spec_Suffix
: constant String :=
138 Get_Name_String
(Naming
.Ada_Spec_Suffix
);
139 Body_Suffix
: constant String :=
140 Get_Name_String
(Naming
.Ada_Body_Suffix
);
142 Truncated
: Boolean := False;
145 if Last
> Body_Suffix
'Length
146 and then Name
(Last
- Body_Suffix
'Length + 1 .. Last
) =
150 Last
:= Last
- Body_Suffix
'Length;
154 and then Last
> Spec_Suffix
'Length
155 and then Name
(Last
- Spec_Suffix
'Length + 1 .. Last
) =
159 Last
:= Last
- Spec_Suffix
'Length;
164 Name_Buffer
(1 .. Name_Len
) := Name
(1 .. Last
);
169 Attribute_Or_Array_Name
=> Name_Executable
,
170 In_Package
=> Builder_Package
,
176 -- If we have found an Executable attribute, return its value,
177 -- possibly suffixed by the executable suffix.
179 if Executable
/= Nil_Variable_Value
180 and then Executable
.Value
/= Empty_Name
182 -- Get the executable name. If Executable_Suffix is defined,
183 -- make sure that it will be the extension of the executable.
186 Saved_EEOT
: constant Name_Id
:= Executable_Extension_On_Target
;
190 if Executable_Suffix
/= Nil_Variable_Value
191 and then not Executable_Suffix
.Default
193 Executable_Extension_On_Target
:= Executable_Suffix
.Value
;
196 Result
:= Executable_Name
(Executable
.Value
);
197 Executable_Extension_On_Target
:= Saved_EEOT
;
203 Get_Name_String
(Main
);
205 -- If there is a body suffix or a spec suffix, remove this suffix,
206 -- otherwise remove any suffix ('.' followed by other characters), if
209 if Ada_Main
and then Name_Len
> Body_Append
'Length
210 and then Name_Buffer
(Name_Len
- Body_Append
'Length + 1 .. Name_Len
) =
213 -- Found the body termination, remove it
215 Name_Len
:= Name_Len
- Body_Append
'Length;
217 elsif Ada_Main
and then Name_Len
> Spec_Append
'Length
218 and then Name_Buffer
(Name_Len
- Spec_Append
'Length + 1 .. Name_Len
) =
221 -- Found the spec termination, remove it
223 Name_Len
:= Name_Len
- Spec_Append
'Length;
226 -- Remove any suffix, if there is one
228 Get_Name_String
(Strip_Suffix
(Main
));
231 if Executable_Suffix
/= Nil_Variable_Value
232 and then not Executable_Suffix
.Default
234 -- If attribute Executable_Suffix is specified, add this suffix
237 Suffix
: constant String :=
238 Get_Name_String
(Executable_Suffix
.Value
);
240 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ Suffix
'Length) := Suffix
;
241 Name_Len
:= Name_Len
+ Suffix
'Length;
246 -- Otherwise, add the standard suffix for the platform, if any
248 return Executable_Name
(Name_Find
);
271 if File
.Cursor
= File
.Buffer_Len
then
275 A
=> File
.Buffer
'Address,
276 N
=> File
.Buffer
'Length);
278 if File
.Buffer_Len
= 0 then
279 File
.End_Of_File_Reached
:= True;
286 File
.Cursor
:= File
.Cursor
+ 1;
290 -- Start of processing for Get_Line
294 Prj
.Com
.Fail
("Get_Line attempted on an invalid Text_File");
297 Last
:= Line
'First - 1;
299 if not File
.End_Of_File_Reached
then
301 C
:= File
.Buffer
(File
.Cursor
);
302 exit when C
= ASCII
.CR
or else C
= ASCII
.LF
;
307 if File
.End_Of_File_Reached
then
311 exit when Last
= Line
'Last;
314 if C
= ASCII
.CR
or else C
= ASCII
.LF
then
317 if File
.End_Of_File_Reached
then
323 and then File
.Buffer
(File
.Cursor
) = ASCII
.LF
334 function Is_Valid
(File
: Text_File
) return Boolean is
343 procedure Open
(File
: out Text_File
; Name
: String) is
344 FD
: File_Descriptor
;
345 File_Name
: String (1 .. Name
'Length + 1);
348 File_Name
(1 .. Name
'Length) := Name
;
349 File_Name
(File_Name
'Last) := ASCII
.NUL
;
350 FD
:= Open_Read
(Name
=> File_Name
'Address,
351 Fmode
=> GNAT
.OS_Lib
.Text
);
352 if FD
= Invalid_FD
then
355 File
:= new Text_File_Data
;
359 A
=> File
.Buffer
'Address,
360 N
=> File
.Buffer
'Length);
362 if File
.Buffer_Len
= 0 then
363 File
.End_Of_File_Reached
:= True;
375 (Variable
: Variable_Value
;
376 Default
: String) return String
379 if Variable
.Kind
/= Single
380 or else Variable
.Default
381 or else Variable
.Value
= No_Name
385 return Get_Name_String
(Variable
.Value
);
391 In_Array
: Array_Element_Id
;
392 In_Tree
: Project_Tree_Ref
) return Name_Id
394 Current
: Array_Element_Id
:= In_Array
;
395 Element
: Array_Element
;
396 Real_Index
: Name_Id
:= Index
;
399 if Current
= No_Array_Element
then
403 Element
:= In_Tree
.Array_Elements
.Table
(Current
);
405 if not Element
.Index_Case_Sensitive
then
406 Get_Name_String
(Index
);
407 To_Lower
(Name_Buffer
(1 .. Name_Len
));
408 Real_Index
:= Name_Find
;
411 while Current
/= No_Array_Element
loop
412 Element
:= In_Tree
.Array_Elements
.Table
(Current
);
414 if Real_Index
= Element
.Index
then
415 exit when Element
.Value
.Kind
/= Single
;
416 exit when Element
.Value
.Value
= Empty_String
;
417 return Element
.Value
.Value
;
419 Current
:= Element
.Next
;
428 Src_Index
: Int
:= 0;
429 In_Array
: Array_Element_Id
;
430 In_Tree
: Project_Tree_Ref
) return Variable_Value
432 Current
: Array_Element_Id
:= In_Array
;
433 Element
: Array_Element
;
434 Real_Index
: Name_Id
:= Index
;
437 if Current
= No_Array_Element
then
438 return Nil_Variable_Value
;
441 Element
:= In_Tree
.Array_Elements
.Table
(Current
);
443 if not Element
.Index_Case_Sensitive
then
444 Get_Name_String
(Index
);
445 To_Lower
(Name_Buffer
(1 .. Name_Len
));
446 Real_Index
:= Name_Find
;
449 while Current
/= No_Array_Element
loop
450 Element
:= In_Tree
.Array_Elements
.Table
(Current
);
452 if Real_Index
= Element
.Index
and then
453 Src_Index
= Element
.Src_Index
455 return Element
.Value
;
457 Current
:= Element
.Next
;
461 return Nil_Variable_Value
;
467 Attribute_Or_Array_Name
: Name_Id
;
468 In_Package
: Package_Id
;
469 In_Tree
: Project_Tree_Ref
) return Variable_Value
471 The_Array
: Array_Element_Id
;
472 The_Attribute
: Variable_Value
:= Nil_Variable_Value
;
475 if In_Package
/= No_Package
then
477 -- First, look if there is an array element that fits
481 (Name
=> Attribute_Or_Array_Name
,
482 In_Arrays
=> In_Tree
.Packages
.Table
(In_Package
).Decl
.Arrays
,
488 In_Array
=> The_Array
,
491 -- If there is no array element, look for a variable
493 if The_Attribute
= Nil_Variable_Value
then
496 (Variable_Name
=> Attribute_Or_Array_Name
,
497 In_Variables
=> In_Tree
.Packages
.Table
498 (In_Package
).Decl
.Attributes
,
503 return The_Attribute
;
509 In_Arrays
: Array_Id
;
510 In_Tree
: Project_Tree_Ref
) return Name_Id
512 Current
: Array_Id
:= In_Arrays
;
513 The_Array
: Array_Data
;
516 while Current
/= No_Array
loop
517 The_Array
:= In_Tree
.Arrays
.Table
(Current
);
518 if The_Array
.Name
= In_Array
then
520 (Index
, In_Array
=> The_Array
.Value
, In_Tree
=> In_Tree
);
522 Current
:= The_Array
.Next
;
531 In_Arrays
: Array_Id
;
532 In_Tree
: Project_Tree_Ref
) return Array_Element_Id
534 Current
: Array_Id
:= In_Arrays
;
535 The_Array
: Array_Data
;
538 while Current
/= No_Array
loop
539 The_Array
:= In_Tree
.Arrays
.Table
(Current
);
541 if The_Array
.Name
= Name
then
542 return The_Array
.Value
;
544 Current
:= The_Array
.Next
;
548 return No_Array_Element
;
553 In_Packages
: Package_Id
;
554 In_Tree
: Project_Tree_Ref
) return Package_Id
556 Current
: Package_Id
:= In_Packages
;
557 The_Package
: Package_Element
;
560 while Current
/= No_Package
loop
561 The_Package
:= In_Tree
.Packages
.Table
(Current
);
562 exit when The_Package
.Name
/= No_Name
563 and then The_Package
.Name
= Name
;
564 Current
:= The_Package
.Next
;
571 (Variable_Name
: Name_Id
;
572 In_Variables
: Variable_Id
;
573 In_Tree
: Project_Tree_Ref
) return Variable_Value
575 Current
: Variable_Id
:= In_Variables
;
576 The_Variable
: Variable
;
579 while Current
/= No_Variable
loop
581 In_Tree
.Variable_Elements
.Table
(Current
);
583 if Variable_Name
= The_Variable
.Name
then
584 return The_Variable
.Value
;
586 Current
:= The_Variable
.Next
;
590 return Nil_Variable_Value
;
599 Max_Length
: Positive;
600 Separator
: Character)
602 First
: Positive := S
'First;
603 Last
: Natural := S
'Last;
606 -- Nothing to do for empty strings
610 -- Start on a new line if current line is already longer than
613 if Positive (Column
) >= Max_Length
then
617 -- If length of remainder is longer than Max_Length, we need to
618 -- cut the remainder in several lines.
620 while Positive (Column
) + S
'Last - First
> Max_Length
loop
622 -- Try the maximum length possible
624 Last
:= First
+ Max_Length
- Positive (Column
);
626 -- Look for last Separator in the line
628 while Last
>= First
and then S
(Last
) /= Separator
loop
632 -- If we do not find a separator, we output the maximum length
636 Last
:= First
+ Max_Length
- Positive (Column
);
639 Write_Line
(S
(First
.. Last
));
641 -- Set the beginning of the new remainder
646 -- What is left goes to the buffer, without EOL
648 Write_Str
(S
(First
.. S
'Last));