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.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 subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case;
46 The_Casing_Images : constant array (Known_Casing) of String_Access :=
47 (All_Lower_Case => new String'("lowercase"),
48 All_Upper_Case => new String'("UPPERCASE"),
49 Mixed_Case => new String'("MixedCase"));
51 Initialized : Boolean := False;
53 Standard_Dot_Replacement : constant Name_Id :=
54 First_Name_Id + Character'Pos ('-');
56 Std_Naming_Data : Naming_Data :=
57 (Current_Language => No_Name,
58 Dot_Replacement => Standard_Dot_Replacement,
59 Dot_Repl_Loc => No_Location,
60 Casing => All_Lower_Case,
61 Spec_Suffix => No_Array_Element,
62 Current_Spec_Suffix => No_Name,
63 Spec_Suffix_Loc => No_Location,
64 Body_Suffix => No_Array_Element,
65 Current_Body_Suffix => No_Name,
66 Body_Suffix_Loc => No_Location,
67 Separate_Suffix => No_Name,
68 Sep_Suffix_Loc => No_Location,
69 Specs => No_Array_Element,
70 Bodies => No_Array_Element,
71 Specification_Exceptions => No_Array_Element,
72 Implementation_Exceptions => No_Array_Element);
74 Project_Empty : constant Project_Data :=
75 (Languages => No_Languages,
76 Impl_Suffixes => No_Impl_Suffixes,
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 Symbol_Data => No_Symbols,
100 Sources_Present => True,
101 Sources => Nil_String,
102 First_Other_Source => No_Other_Source,
103 Last_Other_Source => No_Other_Source,
104 Imported_Directories_Switches => null,
105 Include_Path => null,
106 Include_Data_Set => False,
107 Source_Dirs => Nil_String,
108 Known_Order_Of_Source_Dirs => True,
109 Object_Directory => No_Name,
110 Display_Object_Dir => No_Name,
111 Exec_Directory => No_Name,
112 Display_Exec_Dir => No_Name,
113 Extends => No_Project,
114 Extended_By => No_Project,
115 Naming => Std_Naming_Data,
116 Decl => No_Declarations,
117 Imported_Projects => Empty_Project_List,
118 Ada_Include_Path => null,
119 Ada_Objects_Path => null,
120 Include_Path_File => No_Name,
121 Objects_Path_File_With_Libs => No_Name,
122 Objects_Path_File_Without_Libs => No_Name,
123 Config_File_Name => No_Name,
124 Config_File_Temp => False,
125 Config_Checked => False,
126 Language_Independent_Checked => False,
132 Unkept_Comments => False);
138 procedure Add_To_Buffer (S : String) is
140 -- If Buffer is too small, double its size
142 if Buffer_Last + S'Length > Buffer'Last then
144 New_Buffer : constant String_Access :=
145 new String (1 .. 2 * Buffer'Last);
148 New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last);
150 Buffer := New_Buffer;
154 Buffer (Buffer_Last + 1 .. Buffer_Last + S'Length) := S;
155 Buffer_Last := Buffer_Last + S'Length;
162 function Empty_Project return Project_Data is
165 return Project_Empty;
172 function Empty_String return Name_Id is
174 return The_Empty_String;
181 procedure Expect (The_Token : Token_Type; Token_Image : String) is
183 if Token /= The_Token then
184 Error_Msg (Token_Image & " expected", Token_Ptr);
188 --------------------------------
189 -- For_Every_Project_Imported --
190 --------------------------------
192 procedure For_Every_Project_Imported
194 With_State : in out State)
197 procedure Check (Project : Project_Id);
198 -- Check if a project has already been seen.
199 -- If not seen, mark it as seen, call Action,
200 -- and check all its imported projects.
202 procedure Check (Project : Project_Id) is
206 if not Projects.Table (Project).Seen then
207 Projects.Table (Project).Seen := True;
208 Action (Project, With_State);
210 List := Projects.Table (Project).Imported_Projects;
211 while List /= Empty_Project_List loop
212 Check (Project_Lists.Table (List).Project);
213 List := Project_Lists.Table (List).Next;
219 for Project in Projects.First .. Projects.Last loop
220 Projects.Table (Project).Seen := False;
223 Check (Project => By);
224 end For_Every_Project_Imported;
230 function Image (Casing : Casing_Type) return String is
232 return The_Casing_Images (Casing).all;
239 procedure Initialize is
241 if not Initialized then
244 The_Empty_String := Name_Find;
245 Empty_Name := The_Empty_String;
247 Name_Buffer (1 .. 4) := ".ads";
248 Default_Ada_Spec_Suffix := Name_Find;
250 Name_Buffer (1 .. 4) := ".adb";
251 Default_Ada_Body_Suffix := Name_Find;
253 Name_Buffer (1) := '/';
256 for Lang in Programming_Language loop
257 Name_Len := Lang_Names (Lang)'Length;
258 Name_Buffer (1 .. Name_Len) := Lang_Names (Lang).all;
259 Lang_Name_Ids (Lang) := Name_Find;
260 Name_Len := Lang_Suffixes (Lang)'Length;
261 Name_Buffer (1 .. Name_Len) := Lang_Suffixes (Lang).all;
262 Lang_Suffix_Ids (Lang) := Name_Find;
265 Std_Naming_Data.Current_Spec_Suffix := Default_Ada_Spec_Suffix;
266 Std_Naming_Data.Current_Body_Suffix := Default_Ada_Body_Suffix;
267 Std_Naming_Data.Separate_Suffix := Default_Ada_Body_Suffix;
268 Register_Default_Naming_Scheme
269 (Language => Name_Ada,
270 Default_Spec_Suffix => Default_Ada_Spec_Suffix,
271 Default_Body_Suffix => Default_Ada_Body_Suffix);
274 Set_Name_Table_Byte (Name_Project, Token_Type'Pos (Tok_Project));
275 Set_Name_Table_Byte (Name_Extends, Token_Type'Pos (Tok_Extends));
276 Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External));
280 ------------------------------------
281 -- Register_Default_Naming_Scheme --
282 ------------------------------------
284 procedure Register_Default_Naming_Scheme
286 Default_Spec_Suffix : Name_Id;
287 Default_Body_Suffix : Name_Id)
290 Suffix : Array_Element_Id;
291 Found : Boolean := False;
292 Element : Array_Element;
295 -- Get the language name in small letters
297 Get_Name_String (Language);
298 Name_Buffer (1 .. Name_Len) := To_Lower (Name_Buffer (1 .. Name_Len));
301 Suffix := Std_Naming_Data.Spec_Suffix;
304 -- Look for an element of the spec sufix array indexed by the language
305 -- name. If one is found, put the default value.
307 while Suffix /= No_Array_Element and then not Found loop
308 Element := Array_Elements.Table (Suffix);
310 if Element.Index = Lang then
312 Element.Value.Value := Default_Spec_Suffix;
313 Array_Elements.Table (Suffix) := Element;
316 Suffix := Element.Next;
320 -- If none can be found, create a new one.
325 Index_Case_Sensitive => False,
326 Value => (Project => No_Project,
328 Location => No_Location,
330 Value => Default_Spec_Suffix),
331 Next => Std_Naming_Data.Spec_Suffix);
332 Array_Elements.Increment_Last;
333 Array_Elements.Table (Array_Elements.Last) := Element;
334 Std_Naming_Data.Spec_Suffix := Array_Elements.Last;
337 Suffix := Std_Naming_Data.Body_Suffix;
340 -- Look for an element of the body sufix array indexed by the language
341 -- name. If one is found, put the default value.
343 while Suffix /= No_Array_Element and then not Found loop
344 Element := Array_Elements.Table (Suffix);
346 if Element.Index = Lang then
348 Element.Value.Value := Default_Body_Suffix;
349 Array_Elements.Table (Suffix) := Element;
352 Suffix := Element.Next;
356 -- If none can be found, create a new one.
361 Index_Case_Sensitive => False,
362 Value => (Project => No_Project,
364 Location => No_Location,
366 Value => Default_Body_Suffix),
367 Next => Std_Naming_Data.Body_Suffix);
368 Array_Elements.Increment_Last;
369 Array_Elements.Table (Array_Elements.Last) := Element;
370 Std_Naming_Data.Body_Suffix := Array_Elements.Last;
372 end Register_Default_Naming_Scheme;
384 Variable_Elements.Init;
385 String_Elements.Init;
387 Prj.Com.Units_Htable.Reset;
388 Prj.Com.Files_Htable.Reset;
391 ------------------------
392 -- Same_Naming_Scheme --
393 ------------------------
395 function Same_Naming_Scheme
396 (Left, Right : Naming_Data)
400 return Left.Dot_Replacement = Right.Dot_Replacement
401 and then Left.Casing = Right.Casing
402 and then Left.Current_Spec_Suffix = Right.Current_Spec_Suffix
403 and then Left.Current_Body_Suffix = Right.Current_Body_Suffix
404 and then Left.Separate_Suffix = Right.Separate_Suffix;
405 end Same_Naming_Scheme;
407 --------------------------
408 -- Standard_Naming_Data --
409 --------------------------
411 function Standard_Naming_Data return Naming_Data is
414 return Std_Naming_Data;
415 end Standard_Naming_Data;
421 function Value (Image : String) return Casing_Type is
423 for Casing in The_Casing_Images'Range loop
424 if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then
429 raise Constraint_Error;
433 -- Make sure that the standard project file extension is compatible
434 -- with canonical case file naming.
436 Canonical_Case_File_Name (Project_File_Extension);