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.Characters.Handling; use Ada.Characters.Handling;
29 with Namet; use Namet;
30 with Osint; use Osint;
34 with Prj.Err; use Prj.Err;
35 with Scans; use Scans;
36 with Snames; use Snames;
38 with GNAT.OS_Lib; use GNAT.OS_Lib;
42 The_Empty_String : Name_Id;
44 Ada_Language : constant Name_Id := Name_Ada;
46 subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case;
48 The_Casing_Images : constant array (Known_Casing) of String_Access :=
49 (All_Lower_Case => new String'("lowercase"),
50 All_Upper_Case => new String'("UPPERCASE"),
51 Mixed_Case => new String'("MixedCase"));
53 Initialized : Boolean := False;
55 Standard_Dot_Replacement : constant Name_Id :=
56 First_Name_Id + Character'Pos ('-');
58 Std_Naming_Data : Naming_Data :=
59 (Current_Language => No_Name,
60 Dot_Replacement => Standard_Dot_Replacement,
61 Dot_Repl_Loc => No_Location,
62 Casing => All_Lower_Case,
63 Spec_Suffix => No_Array_Element,
64 Current_Spec_Suffix => No_Name,
65 Spec_Suffix_Loc => No_Location,
66 Body_Suffix => No_Array_Element,
67 Current_Body_Suffix => No_Name,
68 Body_Suffix_Loc => No_Location,
69 Separate_Suffix => No_Name,
70 Sep_Suffix_Loc => No_Location,
71 Specs => No_Array_Element,
72 Bodies => No_Array_Element,
73 Specification_Exceptions => No_Array_Element,
74 Implementation_Exceptions => No_Array_Element);
76 Project_Empty : constant Project_Data :=
77 (First_Referred_By => No_Project,
81 Display_Path_Name => No_Name,
82 Location => No_Location,
85 Display_Directory => No_Name,
88 Library_Dir => No_Name,
89 Display_Library_Dir => No_Name,
90 Library_Src_Dir => No_Name,
91 Display_Library_Src_Dir => No_Name,
92 Library_Name => No_Name,
93 Library_Kind => Static,
94 Lib_Internal_Name => No_Name,
95 Lib_Elaboration => False,
96 Standalone_Library => False,
97 Lib_Interface_ALIs => Nil_String,
98 Lib_Auto_Init => False,
99 Sources_Present => True,
100 Sources => Nil_String,
101 Source_Dirs => Nil_String,
102 Known_Order_Of_Source_Dirs => True,
103 Object_Directory => No_Name,
104 Display_Object_Dir => No_Name,
105 Exec_Directory => No_Name,
106 Display_Exec_Dir => No_Name,
107 Extends => No_Project,
108 Extended_By => No_Project,
109 Naming => Std_Naming_Data,
110 Decl => No_Declarations,
111 Imported_Projects => Empty_Project_List,
112 Ada_Include_Path => null,
113 Ada_Objects_Path => null,
114 Include_Path_File => No_Name,
115 Objects_Path_File_With_Libs => No_Name,
116 Objects_Path_File_Without_Libs => No_Name,
117 Config_File_Name => No_Name,
118 Config_File_Temp => False,
119 Config_Checked => False,
120 Language_Independent_Checked => False,
131 procedure Add_To_Buffer (S : String) is
133 -- If Buffer is too small, double its size
135 if Buffer_Last + S'Length > Buffer'Last then
137 New_Buffer : constant String_Access :=
138 new String (1 .. 2 * Buffer'Last);
141 New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last);
143 Buffer := New_Buffer;
147 Buffer (Buffer_Last + 1 .. Buffer_Last + S'Length) := S;
148 Buffer_Last := Buffer_Last + S'Length;
155 function Empty_Project return Project_Data is
158 return Project_Empty;
165 function Empty_String return Name_Id is
167 return The_Empty_String;
174 procedure Expect (The_Token : Token_Type; Token_Image : String) is
176 if Token /= The_Token then
177 Error_Msg (Token_Image & " expected", Token_Ptr);
181 --------------------------------
182 -- For_Every_Project_Imported --
183 --------------------------------
185 procedure For_Every_Project_Imported
187 With_State : in out State)
190 procedure Check (Project : Project_Id);
191 -- Check if a project has already been seen.
192 -- If not seen, mark it as seen, call Action,
193 -- and check all its imported projects.
195 procedure Check (Project : Project_Id) is
199 if not Projects.Table (Project).Seen then
200 Projects.Table (Project).Seen := True;
201 Action (Project, With_State);
203 List := Projects.Table (Project).Imported_Projects;
204 while List /= Empty_Project_List loop
205 Check (Project_Lists.Table (List).Project);
206 List := Project_Lists.Table (List).Next;
212 for Project in Projects.First .. Projects.Last loop
213 Projects.Table (Project).Seen := False;
216 Check (Project => By);
217 end For_Every_Project_Imported;
223 function Image (Casing : Casing_Type) return String is
225 return The_Casing_Images (Casing).all;
232 procedure Initialize is
234 if not Initialized then
237 The_Empty_String := Name_Find;
238 Empty_Name := The_Empty_String;
240 Name_Buffer (1 .. 4) := ".ads";
241 Default_Ada_Spec_Suffix := Name_Find;
243 Name_Buffer (1 .. 4) := ".adb";
244 Default_Ada_Body_Suffix := Name_Find;
246 Name_Buffer (1) := '/';
248 Std_Naming_Data.Current_Spec_Suffix := Default_Ada_Spec_Suffix;
249 Std_Naming_Data.Current_Body_Suffix := Default_Ada_Body_Suffix;
250 Std_Naming_Data.Separate_Suffix := Default_Ada_Body_Suffix;
251 Register_Default_Naming_Scheme
252 (Language => Ada_Language,
253 Default_Spec_Suffix => Default_Ada_Spec_Suffix,
254 Default_Body_Suffix => Default_Ada_Body_Suffix);
257 Set_Name_Table_Byte (Name_Project, Token_Type'Pos (Tok_Project));
258 Set_Name_Table_Byte (Name_Extends, Token_Type'Pos (Tok_Extends));
259 Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External));
263 ------------------------------------
264 -- Register_Default_Naming_Scheme --
265 ------------------------------------
267 procedure Register_Default_Naming_Scheme
269 Default_Spec_Suffix : Name_Id;
270 Default_Body_Suffix : Name_Id)
273 Suffix : Array_Element_Id;
274 Found : Boolean := False;
275 Element : Array_Element;
278 -- Get the language name in small letters
280 Get_Name_String (Language);
281 Name_Buffer (1 .. Name_Len) := To_Lower (Name_Buffer (1 .. Name_Len));
284 Suffix := Std_Naming_Data.Spec_Suffix;
287 -- Look for an element of the spec sufix array indexed by the language
288 -- name. If one is found, put the default value.
290 while Suffix /= No_Array_Element and then not Found loop
291 Element := Array_Elements.Table (Suffix);
293 if Element.Index = Lang then
295 Element.Value.Value := Default_Spec_Suffix;
296 Array_Elements.Table (Suffix) := Element;
299 Suffix := Element.Next;
303 -- If none can be found, create a new one.
308 Index_Case_Sensitive => False,
309 Value => (Project => No_Project,
311 Location => No_Location,
313 Value => Default_Spec_Suffix),
314 Next => Std_Naming_Data.Spec_Suffix);
315 Array_Elements.Increment_Last;
316 Array_Elements.Table (Array_Elements.Last) := Element;
317 Std_Naming_Data.Spec_Suffix := Array_Elements.Last;
320 Suffix := Std_Naming_Data.Body_Suffix;
323 -- Look for an element of the body sufix array indexed by the language
324 -- name. If one is found, put the default value.
326 while Suffix /= No_Array_Element and then not Found loop
327 Element := Array_Elements.Table (Suffix);
329 if Element.Index = Lang then
331 Element.Value.Value := Default_Body_Suffix;
332 Array_Elements.Table (Suffix) := Element;
335 Suffix := Element.Next;
339 -- If none can be found, create a new one.
344 Index_Case_Sensitive => False,
345 Value => (Project => No_Project,
347 Location => No_Location,
349 Value => Default_Body_Suffix),
350 Next => Std_Naming_Data.Body_Suffix);
351 Array_Elements.Increment_Last;
352 Array_Elements.Table (Array_Elements.Last) := Element;
353 Std_Naming_Data.Body_Suffix := Array_Elements.Last;
355 end Register_Default_Naming_Scheme;
367 Variable_Elements.Init;
368 String_Elements.Init;
370 Prj.Com.Units_Htable.Reset;
373 ------------------------
374 -- Same_Naming_Scheme --
375 ------------------------
377 function Same_Naming_Scheme
378 (Left, Right : Naming_Data)
382 return Left.Dot_Replacement = Right.Dot_Replacement
383 and then Left.Casing = Right.Casing
384 and then Left.Current_Spec_Suffix = Right.Current_Spec_Suffix
385 and then Left.Current_Body_Suffix = Right.Current_Body_Suffix
386 and then Left.Separate_Suffix = Right.Separate_Suffix;
387 end Same_Naming_Scheme;
398 --------------------------
399 -- Standard_Naming_Data --
400 --------------------------
402 function Standard_Naming_Data return Naming_Data is
405 return Std_Naming_Data;
406 end Standard_Naming_Data;
412 function Value (Image : String) return Casing_Type is
414 for Casing in The_Casing_Images'Range loop
415 if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then
420 raise Constraint_Error;
424 -- Make sure that the standard project file extension is compatible
425 -- with canonical case file naming.
427 Canonical_Case_File_Name (Project_File_Extension);