1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2004 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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
;
37 package body Prj
.Util
is
39 procedure Free
is new Ada
.Unchecked_Deallocation
40 (Text_File_Data
, Text_File
);
46 procedure Close
(File
: in out Text_File
) is
49 Prj
.Com
.Fail
("Close attempted on an invalid Text_File");
52 -- Close file, no need to test status, since this is a file that we
53 -- read, and the file was read successfully before we closed it.
63 function End_Of_File
(File
: Text_File
) return Boolean is
66 Prj
.Com
.Fail
("End_Of_File attempted on an invalid Text_File");
69 return File
.End_Of_File_Reached
;
76 function Executable_Of
77 (Project
: Project_Id
;
80 Ada_Main
: Boolean := True) return Name_Id
82 pragma Assert
(Project
/= No_Project
);
84 The_Packages
: constant Package_Id
:=
85 Projects
.Table
(Project
).Decl
.Packages
;
87 Builder_Package
: constant Prj
.Package_Id
:=
89 (Name
=> Name_Builder
,
90 In_Packages
=> The_Packages
);
92 Executable
: Variable_Value
:=
96 Attribute_Or_Array_Name
=> Name_Executable
,
97 In_Package
=> Builder_Package
);
99 Executable_Suffix
: constant Variable_Value
:=
103 Attribute_Or_Array_Name
=>
104 Name_Executable_Suffix
,
105 In_Package
=> Builder_Package
);
107 Body_Append
: constant String := Get_Name_String
110 Naming
.Current_Body_Suffix
);
112 Spec_Append
: constant String := Get_Name_String
115 Naming
.Current_Spec_Suffix
);
118 if Builder_Package
/= No_Package
then
119 if Executable
= Nil_Variable_Value
and Ada_Main
then
120 Get_Name_String
(Main
);
122 -- Try as index the name minus the implementation suffix or minus
123 -- the specification suffix.
126 Name
: constant String (1 .. Name_Len
) :=
127 Name_Buffer
(1 .. Name_Len
);
128 Last
: Positive := Name_Len
;
130 Naming
: constant Naming_Data
:=
131 Projects
.Table
(Project
).Naming
;
133 Spec_Suffix
: constant String :=
134 Get_Name_String
(Naming
.Current_Spec_Suffix
);
135 Body_Suffix
: constant String :=
136 Get_Name_String
(Naming
.Current_Body_Suffix
);
138 Truncated
: Boolean := False;
141 if Last
> Body_Suffix
'Length
142 and then Name
(Last
- Body_Suffix
'Length + 1 .. Last
) =
146 Last
:= Last
- Body_Suffix
'Length;
150 and then Last
> Spec_Suffix
'Length
151 and then Name
(Last
- Spec_Suffix
'Length + 1 .. Last
) =
155 Last
:= Last
- Spec_Suffix
'Length;
160 Name_Buffer
(1 .. Name_Len
) := Name
(1 .. Last
);
165 Attribute_Or_Array_Name
=> Name_Executable
,
166 In_Package
=> Builder_Package
);
171 -- If we have found an Executable attribute, return its value,
172 -- possibly suffixed by the executable suffix.
174 if Executable
/= Nil_Variable_Value
175 and then Executable
.Value
/= Empty_Name
178 Exec_Suffix
: String_Access
:= Get_Executable_Suffix
;
179 Result
: Name_Id
:= Executable
.Value
;
182 if Exec_Suffix
'Length /= 0 then
183 Get_Name_String
(Executable
.Value
);
184 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
186 -- If the Executable does not end with the executable
189 if Name_Len
<= Exec_Suffix
'Length
192 (Name_Len
- Exec_Suffix
'Length + 1 .. Name_Len
) /=
195 -- Get the original Executable to keep the correct
196 -- case for systems where file names are case
197 -- insensitive (Windows).
199 Get_Name_String
(Executable
.Value
);
201 (Name_Len
+ 1 .. Name_Len
+ Exec_Suffix
'Length) :=
203 Name_Len
:= Name_Len
+ Exec_Suffix
'Length;
215 Get_Name_String
(Main
);
217 -- If there is a body suffix or a spec suffix, remove this suffix,
218 -- otherwise remove any suffix ('.' followed by other characters), if
221 if Ada_Main
and then Name_Len
> Body_Append
'Length
222 and then Name_Buffer
(Name_Len
- Body_Append
'Length + 1 .. Name_Len
) =
225 -- Found the body termination, remove it
227 Name_Len
:= Name_Len
- Body_Append
'Length;
229 elsif Ada_Main
and then Name_Len
> Spec_Append
'Length
230 and then Name_Buffer
(Name_Len
- Spec_Append
'Length + 1 .. Name_Len
) =
233 -- Found the spec termination, remove it
235 Name_Len
:= Name_Len
- Spec_Append
'Length;
238 -- Remove any suffix, if there is one
240 Get_Name_String
(Strip_Suffix
(Main
));
243 if Executable_Suffix
/= Nil_Variable_Value
244 and then not Executable_Suffix
.Default
246 -- If attribute Executable_Suffix is specified, add this suffix
249 Suffix
: constant String :=
250 Get_Name_String
(Executable_Suffix
.Value
);
252 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ Suffix
'Length) := Suffix
;
253 Name_Len
:= Name_Len
+ Suffix
'Length;
258 -- Otherwise, add the standard suffix for the platform, if any
260 return Executable_Name
(Name_Find
);
283 if File
.Cursor
= File
.Buffer_Len
then
287 A
=> File
.Buffer
'Address,
288 N
=> File
.Buffer
'Length);
290 if File
.Buffer_Len
= 0 then
291 File
.End_Of_File_Reached
:= True;
298 File
.Cursor
:= File
.Cursor
+ 1;
302 -- Start of processing for Get_Line
306 Prj
.Com
.Fail
("Get_Line attempted on an invalid Text_File");
309 Last
:= Line
'First - 1;
311 if not File
.End_Of_File_Reached
then
313 C
:= File
.Buffer
(File
.Cursor
);
314 exit when C
= ASCII
.CR
or else C
= ASCII
.LF
;
319 if File
.End_Of_File_Reached
then
323 exit when Last
= Line
'Last;
326 if C
= ASCII
.CR
or else C
= ASCII
.LF
then
329 if File
.End_Of_File_Reached
then
335 and then File
.Buffer
(File
.Cursor
) = ASCII
.LF
346 function Is_Valid
(File
: Text_File
) return Boolean is
355 procedure Open
(File
: out Text_File
; Name
: in String) is
356 FD
: File_Descriptor
;
357 File_Name
: String (1 .. Name
'Length + 1);
360 File_Name
(1 .. Name
'Length) := Name
;
361 File_Name
(File_Name
'Last) := ASCII
.NUL
;
362 FD
:= Open_Read
(Name
=> File_Name
'Address,
363 Fmode
=> GNAT
.OS_Lib
.Text
);
364 if FD
= Invalid_FD
then
367 File
:= new Text_File_Data
;
371 A
=> File
.Buffer
'Address,
372 N
=> File
.Buffer
'Length);
374 if File
.Buffer_Len
= 0 then
375 File
.End_Of_File_Reached
:= True;
387 (Variable
: Variable_Value
;
388 Default
: String) return String
391 if Variable
.Kind
/= Single
392 or else Variable
.Default
393 or else Variable
.Value
= No_Name
397 return Get_Name_String
(Variable
.Value
);
403 In_Array
: Array_Element_Id
) return Name_Id
405 Current
: Array_Element_Id
:= In_Array
;
406 Element
: Array_Element
;
407 Real_Index
: Name_Id
:= Index
;
410 if Current
= No_Array_Element
then
414 Element
:= Array_Elements
.Table
(Current
);
416 if not Element
.Index_Case_Sensitive
then
417 Get_Name_String
(Index
);
418 To_Lower
(Name_Buffer
(1 .. Name_Len
));
419 Real_Index
:= Name_Find
;
422 while Current
/= No_Array_Element
loop
423 Element
:= Array_Elements
.Table
(Current
);
425 if Real_Index
= Element
.Index
then
426 exit when Element
.Value
.Kind
/= Single
;
427 exit when Element
.Value
.Value
= Empty_String
;
428 return Element
.Value
.Value
;
430 Current
:= Element
.Next
;
439 Src_Index
: Int
:= 0;
440 In_Array
: Array_Element_Id
) return Variable_Value
442 Current
: Array_Element_Id
:= In_Array
;
443 Element
: Array_Element
;
444 Real_Index
: Name_Id
:= Index
;
447 if Current
= No_Array_Element
then
448 return Nil_Variable_Value
;
451 Element
:= Array_Elements
.Table
(Current
);
453 if not Element
.Index_Case_Sensitive
then
454 Get_Name_String
(Index
);
455 To_Lower
(Name_Buffer
(1 .. Name_Len
));
456 Real_Index
:= Name_Find
;
459 while Current
/= No_Array_Element
loop
460 Element
:= Array_Elements
.Table
(Current
);
462 if Real_Index
= Element
.Index
and then
463 Src_Index
= Element
.Src_Index
465 return Element
.Value
;
467 Current
:= Element
.Next
;
471 return Nil_Variable_Value
;
477 Attribute_Or_Array_Name
: Name_Id
;
478 In_Package
: Package_Id
) return Variable_Value
480 The_Array
: Array_Element_Id
;
481 The_Attribute
: Variable_Value
:= Nil_Variable_Value
;
484 if In_Package
/= No_Package
then
486 -- First, look if there is an array element that fits
490 (Name
=> Attribute_Or_Array_Name
,
491 In_Arrays
=> Packages
.Table
(In_Package
).Decl
.Arrays
);
496 In_Array
=> The_Array
);
498 -- If there is no array element, look for a variable
500 if The_Attribute
= Nil_Variable_Value
then
503 (Variable_Name
=> Attribute_Or_Array_Name
,
504 In_Variables
=> Packages
.Table
(In_Package
).Decl
.Attributes
);
508 return The_Attribute
;
514 In_Arrays
: Array_Id
) return Name_Id
516 Current
: Array_Id
:= In_Arrays
;
517 The_Array
: Array_Data
;
520 while Current
/= No_Array
loop
521 The_Array
:= Arrays
.Table
(Current
);
522 if The_Array
.Name
= In_Array
then
523 return Value_Of
(Index
, In_Array
=> The_Array
.Value
);
525 Current
:= The_Array
.Next
;
534 In_Arrays
: Array_Id
) return Array_Element_Id
536 Current
: Array_Id
:= In_Arrays
;
537 The_Array
: Array_Data
;
540 while Current
/= No_Array
loop
541 The_Array
:= Arrays
.Table
(Current
);
543 if The_Array
.Name
= Name
then
544 return The_Array
.Value
;
546 Current
:= The_Array
.Next
;
550 return No_Array_Element
;
555 In_Packages
: Package_Id
) return Package_Id
557 Current
: Package_Id
:= In_Packages
;
558 The_Package
: Package_Element
;
561 while Current
/= No_Package
loop
562 The_Package
:= Packages
.Table
(Current
);
563 exit when The_Package
.Name
/= No_Name
564 and then The_Package
.Name
= Name
;
565 Current
:= The_Package
.Next
;
572 (Variable_Name
: Name_Id
;
573 In_Variables
: Variable_Id
) return Variable_Value
575 Current
: Variable_Id
:= In_Variables
;
576 The_Variable
: Variable
;
579 while Current
/= No_Variable
loop
580 The_Variable
:= Variable_Elements
.Table
(Current
);
582 if Variable_Name
= The_Variable
.Name
then
583 return The_Variable
.Value
;
585 Current
:= The_Variable
.Next
;
589 return Nil_Variable_Value
;
598 Max_Length
: Positive;
599 Separator
: Character)
601 First
: Positive := S
'First;
602 Last
: Natural := S
'Last;
605 -- Nothing to do for empty strings
609 -- Start on a new line if current line is already longer than
612 if Positive (Column
) >= Max_Length
then
616 -- If length of remainder is longer than Max_Length, we need to
617 -- cut the remainder in several lines.
619 while Positive (Column
) + S
'Last - First
> Max_Length
loop
621 -- Try the maximum length possible
623 Last
:= First
+ Max_Length
- Positive (Column
);
625 -- Look for last Separator in the line
627 while Last
>= First
and then S
(Last
) /= Separator
loop
631 -- If we do not find a separator, we output the maximum length
635 Last
:= First
+ Max_Length
- Positive (Column
);
638 Write_Line
(S
(First
.. Last
));
640 -- Set the beginning of the new remainder
645 -- What is left goes to the buffer, without EOL
647 Write_Str
(S
(First
.. S
'Last));