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;
37 with Uintp; use Uintp;
39 with GNAT.OS_Lib; use GNAT.OS_Lib;
43 The_Empty_String : Name_Id;
45 subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case;
47 The_Casing_Images : constant array (Known_Casing) of String_Access :=
48 (All_Lower_Case => new String'("lowercase"),
49 All_Upper_Case => new String'("UPPERCASE"),
50 Mixed_Case => new String'("MixedCase"));
52 Initialized : Boolean := False;
54 Standard_Dot_Replacement : constant Name_Id :=
55 First_Name_Id + Character'Pos ('-');
57 Std_Naming_Data : Naming_Data :=
58 (Current_Language => No_Name,
59 Dot_Replacement => Standard_Dot_Replacement,
60 Dot_Repl_Loc => No_Location,
61 Casing => All_Lower_Case,
62 Spec_Suffix => No_Array_Element,
63 Current_Spec_Suffix => No_Name,
64 Spec_Suffix_Loc => No_Location,
65 Body_Suffix => No_Array_Element,
66 Current_Body_Suffix => No_Name,
67 Body_Suffix_Loc => No_Location,
68 Separate_Suffix => No_Name,
69 Sep_Suffix_Loc => No_Location,
70 Specs => No_Array_Element,
71 Bodies => No_Array_Element,
72 Specification_Exceptions => No_Array_Element,
73 Implementation_Exceptions => No_Array_Element);
75 Project_Empty : constant Project_Data :=
76 (Languages => No_Languages,
77 Impl_Suffixes => No_Impl_Suffixes,
78 First_Referred_By => No_Project,
82 Display_Path_Name => No_Name,
83 Location => No_Location,
86 Display_Directory => No_Name,
89 Library_Dir => No_Name,
90 Display_Library_Dir => No_Name,
91 Library_Src_Dir => No_Name,
92 Display_Library_Src_Dir => No_Name,
93 Library_Name => No_Name,
94 Library_Kind => Static,
95 Lib_Internal_Name => No_Name,
96 Lib_Elaboration => False,
97 Standalone_Library => False,
98 Lib_Interface_ALIs => Nil_String,
99 Lib_Auto_Init => False,
100 Symbol_Data => No_Symbols,
101 Sources_Present => True,
102 Sources => Nil_String,
103 First_Other_Source => No_Other_Source,
104 Last_Other_Source => No_Other_Source,
105 Imported_Directories_Switches => null,
106 Include_Path => null,
107 Include_Data_Set => False,
108 Source_Dirs => Nil_String,
109 Known_Order_Of_Source_Dirs => True,
110 Object_Directory => No_Name,
111 Display_Object_Dir => No_Name,
112 Exec_Directory => No_Name,
113 Display_Exec_Dir => No_Name,
114 Extends => No_Project,
115 Extended_By => No_Project,
116 Naming => Std_Naming_Data,
117 Decl => No_Declarations,
118 Imported_Projects => Empty_Project_List,
119 Ada_Include_Path => null,
120 Ada_Objects_Path => null,
121 Include_Path_File => No_Name,
122 Objects_Path_File_With_Libs => No_Name,
123 Objects_Path_File_Without_Libs => No_Name,
124 Config_File_Name => No_Name,
125 Config_File_Temp => False,
126 Config_Checked => False,
127 Language_Independent_Checked => False,
133 Unkept_Comments => False);
139 procedure Add_To_Buffer (S : String) is
141 -- If Buffer is too small, double its size
143 if Buffer_Last + S'Length > Buffer'Last then
145 New_Buffer : constant String_Access :=
146 new String (1 .. 2 * Buffer'Last);
149 New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last);
151 Buffer := New_Buffer;
155 Buffer (Buffer_Last + 1 .. Buffer_Last + S'Length) := S;
156 Buffer_Last := Buffer_Last + S'Length;
163 function Empty_Project return Project_Data is
166 return Project_Empty;
173 function Empty_String return Name_Id is
175 return The_Empty_String;
182 procedure Expect (The_Token : Token_Type; Token_Image : String) is
184 if Token /= The_Token then
185 Error_Msg (Token_Image & " expected", Token_Ptr);
189 --------------------------------
190 -- For_Every_Project_Imported --
191 --------------------------------
193 procedure For_Every_Project_Imported
195 With_State : in out State)
198 procedure Check (Project : Project_Id);
199 -- Check if a project has already been seen.
200 -- If not seen, mark it as seen, call Action,
201 -- and check all its imported projects.
203 procedure Check (Project : Project_Id) is
207 if not Projects.Table (Project).Seen then
208 Projects.Table (Project).Seen := True;
209 Action (Project, With_State);
211 List := Projects.Table (Project).Imported_Projects;
212 while List /= Empty_Project_List loop
213 Check (Project_Lists.Table (List).Project);
214 List := Project_Lists.Table (List).Next;
220 for Project in Projects.First .. Projects.Last loop
221 Projects.Table (Project).Seen := False;
224 Check (Project => By);
225 end For_Every_Project_Imported;
231 function Image (Casing : Casing_Type) return String is
233 return The_Casing_Images (Casing).all;
240 procedure Initialize is
242 if not Initialized then
246 The_Empty_String := Name_Find;
247 Empty_Name := The_Empty_String;
249 Name_Buffer (1 .. 4) := ".ads";
250 Default_Ada_Spec_Suffix := Name_Find;
252 Name_Buffer (1 .. 4) := ".adb";
253 Default_Ada_Body_Suffix := Name_Find;
255 Name_Buffer (1) := '/';
258 for Lang in Programming_Language loop
259 Name_Len := Lang_Names (Lang)'Length;
260 Name_Buffer (1 .. Name_Len) := Lang_Names (Lang).all;
261 Lang_Name_Ids (Lang) := Name_Find;
262 Name_Len := Lang_Suffixes (Lang)'Length;
263 Name_Buffer (1 .. Name_Len) := Lang_Suffixes (Lang).all;
264 Lang_Suffix_Ids (Lang) := Name_Find;
267 Std_Naming_Data.Current_Spec_Suffix := Default_Ada_Spec_Suffix;
268 Std_Naming_Data.Current_Body_Suffix := Default_Ada_Body_Suffix;
269 Std_Naming_Data.Separate_Suffix := Default_Ada_Body_Suffix;
270 Register_Default_Naming_Scheme
271 (Language => Name_Ada,
272 Default_Spec_Suffix => Default_Ada_Spec_Suffix,
273 Default_Body_Suffix => Default_Ada_Body_Suffix);
276 Set_Name_Table_Byte (Name_Project, Token_Type'Pos (Tok_Project));
277 Set_Name_Table_Byte (Name_Extends, Token_Type'Pos (Tok_Extends));
278 Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External));
282 ------------------------------------
283 -- Register_Default_Naming_Scheme --
284 ------------------------------------
286 procedure Register_Default_Naming_Scheme
288 Default_Spec_Suffix : Name_Id;
289 Default_Body_Suffix : Name_Id)
292 Suffix : Array_Element_Id;
293 Found : Boolean := False;
294 Element : Array_Element;
297 -- Get the language name in small letters
299 Get_Name_String (Language);
300 Name_Buffer (1 .. Name_Len) := To_Lower (Name_Buffer (1 .. Name_Len));
303 Suffix := Std_Naming_Data.Spec_Suffix;
306 -- Look for an element of the spec sufix array indexed by the language
307 -- name. If one is found, put the default value.
309 while Suffix /= No_Array_Element and then not Found loop
310 Element := Array_Elements.Table (Suffix);
312 if Element.Index = Lang then
314 Element.Value.Value := Default_Spec_Suffix;
315 Array_Elements.Table (Suffix) := Element;
318 Suffix := Element.Next;
322 -- If none can be found, create a new one.
328 Index_Case_Sensitive => False,
329 Value => (Project => No_Project,
331 Location => No_Location,
333 Value => Default_Spec_Suffix,
335 Next => Std_Naming_Data.Spec_Suffix);
336 Array_Elements.Increment_Last;
337 Array_Elements.Table (Array_Elements.Last) := Element;
338 Std_Naming_Data.Spec_Suffix := Array_Elements.Last;
341 Suffix := Std_Naming_Data.Body_Suffix;
344 -- Look for an element of the body sufix array indexed by the language
345 -- name. If one is found, put the default value.
347 while Suffix /= No_Array_Element and then not Found loop
348 Element := Array_Elements.Table (Suffix);
350 if Element.Index = Lang then
352 Element.Value.Value := Default_Body_Suffix;
353 Array_Elements.Table (Suffix) := Element;
356 Suffix := Element.Next;
360 -- If none can be found, create a new one.
366 Index_Case_Sensitive => False,
367 Value => (Project => No_Project,
369 Location => No_Location,
371 Value => Default_Body_Suffix,
373 Next => Std_Naming_Data.Body_Suffix);
374 Array_Elements.Increment_Last;
375 Array_Elements.Table (Array_Elements.Last) := Element;
376 Std_Naming_Data.Body_Suffix := Array_Elements.Last;
378 end Register_Default_Naming_Scheme;
390 Variable_Elements.Init;
391 String_Elements.Init;
393 Prj.Com.Units_Htable.Reset;
394 Prj.Com.Files_Htable.Reset;
397 ------------------------
398 -- Same_Naming_Scheme --
399 ------------------------
401 function Same_Naming_Scheme
402 (Left, Right : Naming_Data)
406 return Left.Dot_Replacement = Right.Dot_Replacement
407 and then Left.Casing = Right.Casing
408 and then Left.Current_Spec_Suffix = Right.Current_Spec_Suffix
409 and then Left.Current_Body_Suffix = Right.Current_Body_Suffix
410 and then Left.Separate_Suffix = Right.Separate_Suffix;
411 end Same_Naming_Scheme;
413 --------------------------
414 -- Standard_Naming_Data --
415 --------------------------
417 function Standard_Naming_Data return Naming_Data is
420 return Std_Naming_Data;
421 end Standard_Naming_Data;
427 function Value (Image : String) return Casing_Type is
429 for Casing in The_Casing_Images'Range loop
430 if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then
435 raise Constraint_Error;
439 -- Make sure that the standard project file extension is compatible
440 -- with canonical case file naming.
442 Canonical_Case_File_Name (Project_File_Extension);