1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2005 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;
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;
78 In_Tree : Project_Tree_Ref;
81 Ada_Main : Boolean := True) return Name_Id
83 pragma Assert (Project /= No_Project);
85 The_Packages : constant Package_Id :=
86 In_Tree.Projects.Table (Project).Decl.Packages;
88 Builder_Package : constant Prj.Package_Id :=
90 (Name => Name_Builder,
91 In_Packages => The_Packages,
94 Executable : Variable_Value :=
98 Attribute_Or_Array_Name => Name_Executable,
99 In_Package => Builder_Package,
102 Executable_Suffix : constant Variable_Value :=
106 Attribute_Or_Array_Name =>
107 Name_Executable_Suffix,
108 In_Package => Builder_Package,
111 Body_Append : constant String := Get_Name_String
112 (In_Tree.Projects.Table
114 Naming.Ada_Body_Suffix);
116 Spec_Append : constant String := Get_Name_String
117 (In_Tree.Projects.Table
119 Naming.Ada_Spec_Suffix);
122 if Builder_Package /= No_Package then
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
183 Exec_Suffix : String_Access := Get_Executable_Suffix;
184 Result : Name_Id := Executable.Value;
187 if Exec_Suffix'Length /= 0 then
188 Get_Name_String (Executable.Value);
189 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
191 -- If the Executable does not end with the executable
194 if Name_Len <= Exec_Suffix'Length
197 (Name_Len - Exec_Suffix'Length + 1 .. Name_Len) /=
200 -- Get the original Executable to keep the correct
201 -- case for systems where file names are case
202 -- insensitive (Windows).
204 Get_Name_String (Executable.Value);
206 (Name_Len + 1 .. Name_Len + Exec_Suffix'Length) :=
208 Name_Len := Name_Len + Exec_Suffix'Length;
220 Get_Name_String (Main);
222 -- If there is a body suffix or a spec suffix, remove this suffix,
223 -- otherwise remove any suffix ('.' followed by other characters), if
226 if Ada_Main and then Name_Len > Body_Append'Length
227 and then Name_Buffer (Name_Len - Body_Append'Length + 1 .. Name_Len) =
230 -- Found the body termination, remove it
232 Name_Len := Name_Len - Body_Append'Length;
234 elsif Ada_Main and then Name_Len > Spec_Append'Length
235 and then Name_Buffer (Name_Len - Spec_Append'Length + 1 .. Name_Len) =
238 -- Found the spec termination, remove it
240 Name_Len := Name_Len - Spec_Append'Length;
243 -- Remove any suffix, if there is one
245 Get_Name_String (Strip_Suffix (Main));
248 if Executable_Suffix /= Nil_Variable_Value
249 and then not Executable_Suffix.Default
251 -- If attribute Executable_Suffix is specified, add this suffix
254 Suffix : constant String :=
255 Get_Name_String (Executable_Suffix.Value);
257 Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
258 Name_Len := Name_Len + Suffix'Length;
263 -- Otherwise, add the standard suffix for the platform, if any
265 return Executable_Name (Name_Find);
288 if File.Cursor = File.Buffer_Len then
292 A => File.Buffer'Address,
293 N => File.Buffer'Length);
295 if File.Buffer_Len = 0 then
296 File.End_Of_File_Reached := True;
303 File.Cursor := File.Cursor + 1;
307 -- Start of processing for Get_Line
311 Prj.Com.Fail ("Get_Line attempted on an invalid Text_File");
314 Last := Line'First - 1;
316 if not File.End_Of_File_Reached then
318 C := File.Buffer (File.Cursor);
319 exit when C = ASCII.CR or else C = ASCII.LF;
324 if File.End_Of_File_Reached then
328 exit when Last = Line'Last;
331 if C = ASCII.CR or else C = ASCII.LF then
334 if File.End_Of_File_Reached then
340 and then File.Buffer (File.Cursor) = ASCII.LF
351 function Is_Valid (File : Text_File) return Boolean is
360 procedure Open (File : out Text_File; Name : in String) is
361 FD : File_Descriptor;
362 File_Name : String (1 .. Name'Length + 1);
365 File_Name (1 .. Name'Length) := Name;
366 File_Name (File_Name'Last) := ASCII.NUL;
367 FD := Open_Read (Name => File_Name'Address,
368 Fmode => GNAT.OS_Lib.Text);
369 if FD = Invalid_FD then
372 File := new Text_File_Data;
376 A => File.Buffer'Address,
377 N => File.Buffer'Length);
379 if File.Buffer_Len = 0 then
380 File.End_Of_File_Reached := True;
392 (Variable : Variable_Value;
393 Default : String) return String
396 if Variable.Kind /= Single
397 or else Variable.Default
398 or else Variable.Value = No_Name
402 return Get_Name_String (Variable.Value);
408 In_Array : Array_Element_Id;
409 In_Tree : Project_Tree_Ref) return Name_Id
411 Current : Array_Element_Id := In_Array;
412 Element : Array_Element;
413 Real_Index : Name_Id := Index;
416 if Current = No_Array_Element then
420 Element := In_Tree.Array_Elements.Table (Current);
422 if not Element.Index_Case_Sensitive then
423 Get_Name_String (Index);
424 To_Lower (Name_Buffer (1 .. Name_Len));
425 Real_Index := Name_Find;
428 while Current /= No_Array_Element loop
429 Element := In_Tree.Array_Elements.Table (Current);
431 if Real_Index = Element.Index then
432 exit when Element.Value.Kind /= Single;
433 exit when Element.Value.Value = Empty_String;
434 return Element.Value.Value;
436 Current := Element.Next;
445 Src_Index : Int := 0;
446 In_Array : Array_Element_Id;
447 In_Tree : Project_Tree_Ref) return Variable_Value
449 Current : Array_Element_Id := In_Array;
450 Element : Array_Element;
451 Real_Index : Name_Id := Index;
454 if Current = No_Array_Element then
455 return Nil_Variable_Value;
458 Element := In_Tree.Array_Elements.Table (Current);
460 if not Element.Index_Case_Sensitive then
461 Get_Name_String (Index);
462 To_Lower (Name_Buffer (1 .. Name_Len));
463 Real_Index := Name_Find;
466 while Current /= No_Array_Element loop
467 Element := In_Tree.Array_Elements.Table (Current);
469 if Real_Index = Element.Index and then
470 Src_Index = Element.Src_Index
472 return Element.Value;
474 Current := Element.Next;
478 return Nil_Variable_Value;
484 Attribute_Or_Array_Name : Name_Id;
485 In_Package : Package_Id;
486 In_Tree : Project_Tree_Ref) return Variable_Value
488 The_Array : Array_Element_Id;
489 The_Attribute : Variable_Value := Nil_Variable_Value;
492 if In_Package /= No_Package then
494 -- First, look if there is an array element that fits
498 (Name => Attribute_Or_Array_Name,
499 In_Arrays => In_Tree.Packages.Table (In_Package).Decl.Arrays,
505 In_Array => The_Array,
508 -- If there is no array element, look for a variable
510 if The_Attribute = Nil_Variable_Value then
513 (Variable_Name => Attribute_Or_Array_Name,
514 In_Variables => In_Tree.Packages.Table
515 (In_Package).Decl.Attributes,
520 return The_Attribute;
526 In_Arrays : Array_Id;
527 In_Tree : Project_Tree_Ref) return Name_Id
529 Current : Array_Id := In_Arrays;
530 The_Array : Array_Data;
533 while Current /= No_Array loop
534 The_Array := In_Tree.Arrays.Table (Current);
535 if The_Array.Name = In_Array then
537 (Index, In_Array => The_Array.Value, In_Tree => In_Tree);
539 Current := The_Array.Next;
548 In_Arrays : Array_Id;
549 In_Tree : Project_Tree_Ref) return Array_Element_Id
551 Current : Array_Id := In_Arrays;
552 The_Array : Array_Data;
555 while Current /= No_Array loop
556 The_Array := In_Tree.Arrays.Table (Current);
558 if The_Array.Name = Name then
559 return The_Array.Value;
561 Current := The_Array.Next;
565 return No_Array_Element;
570 In_Packages : Package_Id;
571 In_Tree : Project_Tree_Ref) return Package_Id
573 Current : Package_Id := In_Packages;
574 The_Package : Package_Element;
577 while Current /= No_Package loop
578 The_Package := In_Tree.Packages.Table (Current);
579 exit when The_Package.Name /= No_Name
580 and then The_Package.Name = Name;
581 Current := The_Package.Next;
588 (Variable_Name : Name_Id;
589 In_Variables : Variable_Id;
590 In_Tree : Project_Tree_Ref) return Variable_Value
592 Current : Variable_Id := In_Variables;
593 The_Variable : Variable;
596 while Current /= No_Variable loop
598 In_Tree.Variable_Elements.Table (Current);
600 if Variable_Name = The_Variable.Name then
601 return The_Variable.Value;
603 Current := The_Variable.Next;
607 return Nil_Variable_Value;
616 Max_Length : Positive;
617 Separator : Character)
619 First : Positive := S'First;
620 Last : Natural := S'Last;
623 -- Nothing to do for empty strings
627 -- Start on a new line if current line is already longer than
630 if Positive (Column) >= Max_Length then
634 -- If length of remainder is longer than Max_Length, we need to
635 -- cut the remainder in several lines.
637 while Positive (Column) + S'Last - First > Max_Length loop
639 -- Try the maximum length possible
641 Last := First + Max_Length - Positive (Column);
643 -- Look for last Separator in the line
645 while Last >= First and then S (Last) /= Separator loop
649 -- If we do not find a separator, we output the maximum length
653 Last := First + Max_Length - Positive (Column);
656 Write_Line (S (First .. Last));
658 -- Set the beginning of the new remainder
663 -- What is left goes to the buffer, without EOL
665 Write_Str (S (First .. S'Last));