1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2003 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; Main : Name_Id) return Name_Id
79 pragma Assert (Project /= No_Project);
81 The_Packages : constant Package_Id :=
82 Projects.Table (Project).Decl.Packages;
84 Builder_Package : constant Prj.Package_Id :=
86 (Name => Name_Builder,
87 In_Packages => The_Packages);
89 Executable : Variable_Value :=
92 Attribute_Or_Array_Name => Name_Executable,
93 In_Package => Builder_Package);
95 Executable_Suffix : Variable_Value :=
98 Attribute_Or_Array_Name =>
99 Name_Executable_Suffix,
100 In_Package => Builder_Package);
102 Body_Append : constant String := Get_Name_String
105 Naming.Current_Body_Suffix);
107 Spec_Append : constant String := Get_Name_String
110 Naming.Current_Spec_Suffix);
113 if Builder_Package /= No_Package then
114 if Executable = Nil_Variable_Value then
115 Get_Name_String (Main);
117 -- Try as index the name minus the implementation suffix or minus
118 -- the specification suffix.
121 Name : String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
122 Last : Positive := Name_Len;
124 Naming : constant Naming_Data :=
125 Projects.Table (Project).Naming;
127 Spec_Suffix : constant String :=
128 Get_Name_String (Naming.Current_Spec_Suffix);
129 Body_Suffix : constant String :=
130 Get_Name_String (Naming.Current_Body_Suffix);
132 Truncated : Boolean := False;
135 if Last > Body_Suffix'Length
136 and then Name (Last - Body_Suffix'Length + 1 .. Last) =
140 Last := Last - Body_Suffix'Length;
144 and then Last > Spec_Suffix'Length
145 and then Name (Last - Spec_Suffix'Length + 1 .. Last) =
149 Last := Last - Spec_Suffix'Length;
154 Name_Buffer (1 .. Name_Len) := Name (1 .. Last);
158 Attribute_Or_Array_Name => Name_Executable,
159 In_Package => Builder_Package);
164 -- If we have found an Executable attribute, return its value,
165 -- possibly suffixed by the executable suffix.
167 if Executable /= Nil_Variable_Value
168 and then Executable.Value /= Empty_Name
171 Exec_Suffix : String_Access := Get_Executable_Suffix;
172 Result : Name_Id := Executable.Value;
175 if Exec_Suffix'Length /= 0 then
176 Get_Name_String (Executable.Value);
177 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
179 -- If the Executable does not end with the executable
182 if Name_Len <= Exec_Suffix'Length
185 (Name_Len - Exec_Suffix'Length + 1 .. Name_Len) /=
188 -- Get the original Executable to keep the correct
189 -- case for systems where file names are case
190 -- insensitive (Windows).
192 Get_Name_String (Executable.Value);
194 (Name_Len + 1 .. Name_Len + Exec_Suffix'Length) :=
196 Name_Len := Name_Len + Exec_Suffix'Length;
208 Get_Name_String (Main);
210 -- If there is a body suffix or a spec suffix, remove this suffix,
211 -- otherwise remove any suffix ('.' followed by other characters), if
214 if Name_Len > Body_Append'Length
215 and then Name_Buffer (Name_Len - Body_Append'Length + 1 .. Name_Len) =
218 -- Found the body termination, remove it
220 Name_Len := Name_Len - Body_Append'Length;
222 elsif Name_Len > Spec_Append'Length
223 and then Name_Buffer (Name_Len - Spec_Append'Length + 1 .. Name_Len) =
226 -- Found the spec termination, remove it
228 Name_Len := Name_Len - Spec_Append'Length;
231 -- Remove any suffix, if there is one
233 Get_Name_String (Strip_Suffix (Main));
236 if Executable_Suffix /= Nil_Variable_Value
237 and then not Executable_Suffix.Default
239 -- If attribute Executable_Suffix is specified, add this suffix
242 Suffix : constant String :=
243 Get_Name_String (Executable_Suffix.Value);
245 Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
246 Name_Len := Name_Len + Suffix'Length;
251 -- Otherwise, add the standard suffix for the platform, if any
253 return Executable_Name (Name_Find);
276 if File.Cursor = File.Buffer_Len then
280 A => File.Buffer'Address,
281 N => File.Buffer'Length);
283 if File.Buffer_Len = 0 then
284 File.End_Of_File_Reached := True;
291 File.Cursor := File.Cursor + 1;
295 -- Start of processing for Get_Line
299 Prj.Com.Fail ("Get_Line attempted on an invalid Text_File");
302 Last := Line'First - 1;
304 if not File.End_Of_File_Reached then
306 C := File.Buffer (File.Cursor);
307 exit when C = ASCII.CR or else C = ASCII.LF;
312 if File.End_Of_File_Reached then
316 exit when Last = Line'Last;
319 if C = ASCII.CR or else C = ASCII.LF then
322 if File.End_Of_File_Reached then
328 and then File.Buffer (File.Cursor) = ASCII.LF
339 function Is_Valid (File : Text_File) return Boolean is
348 procedure Open (File : out Text_File; Name : in String) is
349 FD : File_Descriptor;
350 File_Name : String (1 .. Name'Length + 1);
353 File_Name (1 .. Name'Length) := Name;
354 File_Name (File_Name'Last) := ASCII.NUL;
355 FD := Open_Read (Name => File_Name'Address,
356 Fmode => GNAT.OS_Lib.Text);
357 if FD = Invalid_FD then
360 File := new Text_File_Data;
364 A => File.Buffer'Address,
365 N => File.Buffer'Length);
367 if File.Buffer_Len = 0 then
368 File.End_Of_File_Reached := True;
380 (Variable : Variable_Value;
385 if Variable.Kind /= Single
386 or else Variable.Default
387 or else Variable.Value = No_Name
391 return Get_Name_String (Variable.Value);
397 In_Array : Array_Element_Id)
400 Current : Array_Element_Id := In_Array;
401 Element : Array_Element;
402 Real_Index : Name_Id := Index;
405 if Current = No_Array_Element then
409 Element := Array_Elements.Table (Current);
411 if not Element.Index_Case_Sensitive then
412 Get_Name_String (Index);
413 To_Lower (Name_Buffer (1 .. Name_Len));
414 Real_Index := Name_Find;
417 while Current /= No_Array_Element loop
418 Element := Array_Elements.Table (Current);
420 if Real_Index = Element.Index then
421 exit when Element.Value.Kind /= Single;
422 exit when Element.Value.Value = Empty_String;
423 return Element.Value.Value;
425 Current := Element.Next;
434 In_Array : Array_Element_Id)
435 return Variable_Value
437 Current : Array_Element_Id := In_Array;
438 Element : Array_Element;
439 Real_Index : Name_Id := Index;
442 if Current = No_Array_Element then
443 return Nil_Variable_Value;
446 Element := Array_Elements.Table (Current);
448 if not Element.Index_Case_Sensitive then
449 Get_Name_String (Index);
450 To_Lower (Name_Buffer (1 .. Name_Len));
451 Real_Index := Name_Find;
454 while Current /= No_Array_Element loop
455 Element := Array_Elements.Table (Current);
457 if Real_Index = Element.Index then
458 return Element.Value;
460 Current := Element.Next;
464 return Nil_Variable_Value;
469 Attribute_Or_Array_Name : Name_Id;
470 In_Package : Package_Id)
471 return Variable_Value
473 The_Array : Array_Element_Id;
474 The_Attribute : Variable_Value := Nil_Variable_Value;
477 if In_Package /= No_Package then
479 -- First, look if there is an array element that fits
483 (Name => Attribute_Or_Array_Name,
484 In_Arrays => Packages.Table (In_Package).Decl.Arrays);
488 In_Array => The_Array);
490 -- If there is no array element, look for a variable
492 if The_Attribute = Nil_Variable_Value then
495 (Variable_Name => Attribute_Or_Array_Name,
496 In_Variables => Packages.Table (In_Package).Decl.Attributes);
500 return The_Attribute;
506 In_Arrays : Array_Id)
509 Current : Array_Id := In_Arrays;
510 The_Array : Array_Data;
513 while Current /= No_Array loop
514 The_Array := Arrays.Table (Current);
515 if The_Array.Name = In_Array then
516 return Value_Of (Index, In_Array => The_Array.Value);
518 Current := The_Array.Next;
527 In_Arrays : Array_Id)
528 return Array_Element_Id
530 Current : Array_Id := In_Arrays;
531 The_Array : Array_Data;
534 while Current /= No_Array loop
535 The_Array := Arrays.Table (Current);
537 if The_Array.Name = Name then
538 return The_Array.Value;
540 Current := The_Array.Next;
544 return No_Array_Element;
549 In_Packages : Package_Id)
552 Current : Package_Id := In_Packages;
553 The_Package : Package_Element;
556 while Current /= No_Package loop
557 The_Package := Packages.Table (Current);
558 exit when The_Package.Name /= No_Name
559 and then The_Package.Name = Name;
560 Current := The_Package.Next;
567 (Variable_Name : Name_Id;
568 In_Variables : Variable_Id)
569 return Variable_Value
571 Current : Variable_Id := In_Variables;
572 The_Variable : Variable;
575 while Current /= No_Variable loop
576 The_Variable := Variable_Elements.Table (Current);
578 if Variable_Name = The_Variable.Name then
579 return The_Variable.Value;
581 Current := The_Variable.Next;
585 return Nil_Variable_Value;
594 Max_Length : Positive;
595 Separator : Character)
597 First : Positive := S'First;
598 Last : Natural := S'Last;
601 -- Nothing to do for empty strings
605 -- Start on a new line if current line is already longer than
608 if Positive (Column) >= Max_Length then
612 -- If length of remainder is longer than Max_Length, we need to
613 -- cut the remainder in several lines.
615 while Positive (Column) + S'Last - First > Max_Length loop
617 -- Try the maximum length possible
619 Last := First + Max_Length - Positive (Column);
621 -- Look for last Separator in the line
623 while Last >= First and then S (Last) /= Separator loop
627 -- If we do not find a separator, we output the maximum length
631 Last := First + Max_Length - Positive (Column);
634 Write_Line (S (First .. Last));
636 -- Set the beginning of the new remainder
641 -- What is left goes to the buffer, without EOL
643 Write_Str (S (First .. S'Last));