1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
11 -- Copyright (C) 2001 Free Software Foundation, Inc. --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- GNAT was originally developed by the GNAT team at New York University. --
25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
27 ------------------------------------------------------------------------------
29 with Ada.Characters.Handling; use Ada.Characters.Handling;
30 with Errout; use Errout;
31 with GNAT.OS_Lib; use GNAT.OS_Lib;
32 with Namet; use Namet;
33 with Osint; use Osint;
37 with Scans; use Scans;
39 with Stringt; use Stringt;
41 with Snames; use Snames;
45 The_Empty_String : String_Id;
47 Ada_Language : constant Name_Id := Name_Ada;
49 subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case;
51 The_Casing_Images : array (Known_Casing) of String_Access :=
52 (All_Lower_Case => new String'("lowercase"),
53 All_Upper_Case => new String'("UPPERCASE"),
54 Mixed_Case => new String'("MixedCase"));
56 Initialized : Boolean := False;
58 Standard_Dot_Replacement : constant Name_Id :=
59 First_Name_Id + Character'Pos ('-');
61 Std_Naming_Data : Naming_Data :=
62 (Current_Language => No_Name,
63 Dot_Replacement => Standard_Dot_Replacement,
64 Dot_Repl_Loc => No_Location,
65 Casing => All_Lower_Case,
66 Specification_Suffix => No_Array_Element,
67 Current_Spec_Suffix => No_Name,
68 Spec_Suffix_Loc => No_Location,
69 Implementation_Suffix => No_Array_Element,
70 Current_Impl_Suffix => No_Name,
71 Impl_Suffix_Loc => No_Location,
72 Separate_Suffix => No_Name,
73 Sep_Suffix_Loc => No_Location,
74 Specifications => No_Array_Element,
75 Bodies => No_Array_Element,
76 Specification_Exceptions => No_Array_Element,
77 Implementation_Exceptions => No_Array_Element);
79 Project_Empty : constant Project_Data :=
80 (First_Referred_By => No_Project,
83 Location => No_Location,
86 Library_Dir => No_Name,
87 Library_Name => No_Name,
88 Library_Kind => Static,
89 Lib_Internal_Name => No_Name,
90 Lib_Elaboration => False,
91 Sources_Present => True,
92 Sources => Nil_String,
93 Source_Dirs => Nil_String,
94 Object_Directory => No_Name,
95 Exec_Directory => No_Name,
96 Modifies => No_Project,
97 Modified_By => No_Project,
98 Naming => Std_Naming_Data,
99 Decl => No_Declarations,
100 Imported_Projects => Empty_Project_List,
101 Include_Path => null,
102 Objects_Path => null,
103 Config_File_Name => No_Name,
104 Config_File_Temp => False,
105 Config_Checked => False,
106 Language_Independent_Checked => False,
116 function Empty_Project return Project_Data is
119 return Project_Empty;
126 function Empty_String return String_Id is
128 return The_Empty_String;
135 procedure Expect (The_Token : Token_Type; Token_Image : String) is
137 if Token /= The_Token then
138 Error_Msg ("""" & Token_Image & """ expected", Token_Ptr);
142 --------------------------------
143 -- For_Every_Project_Imported --
144 --------------------------------
146 procedure For_Every_Project_Imported
148 With_State : in out State)
151 procedure Check (Project : Project_Id);
152 -- Check if a project has already been seen.
153 -- If not seen, mark it as seen, call Action,
154 -- and check all its imported projects.
156 procedure Check (Project : Project_Id) is
160 if not Projects.Table (Project).Seen then
161 Projects.Table (Project).Seen := True;
162 Action (Project, With_State);
164 List := Projects.Table (Project).Imported_Projects;
165 while List /= Empty_Project_List loop
166 Check (Project_Lists.Table (List).Project);
167 List := Project_Lists.Table (List).Next;
173 for Project in Projects.First .. Projects.Last loop
174 Projects.Table (Project).Seen := False;
177 Check (Project => By);
178 end For_Every_Project_Imported;
184 function Image (Casing : Casing_Type) return String is
186 return The_Casing_Images (Casing).all;
193 procedure Initialize is
195 if not Initialized then
199 The_Empty_String := End_String;
201 Name_Buffer (1 .. 4) := ".ads";
202 Default_Ada_Spec_Suffix := Name_Find;
204 Name_Buffer (1 .. 4) := ".adb";
205 Default_Ada_Impl_Suffix := Name_Find;
206 Std_Naming_Data.Current_Spec_Suffix := Default_Ada_Spec_Suffix;
207 Std_Naming_Data.Current_Impl_Suffix := Default_Ada_Impl_Suffix;
208 Std_Naming_Data.Separate_Suffix := Default_Ada_Impl_Suffix;
209 Register_Default_Naming_Scheme
210 (Language => Ada_Language,
211 Default_Spec_Suffix => Default_Ada_Spec_Suffix,
212 Default_Impl_Suffix => Default_Ada_Impl_Suffix);
215 Set_Name_Table_Byte (Name_Project, Token_Type'Pos (Tok_Project));
216 Set_Name_Table_Byte (Name_Extends, Token_Type'Pos (Tok_Extends));
217 Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External));
221 ------------------------------------
222 -- Register_Default_Naming_Scheme --
223 ------------------------------------
225 procedure Register_Default_Naming_Scheme
227 Default_Spec_Suffix : Name_Id;
228 Default_Impl_Suffix : Name_Id)
231 Suffix : Array_Element_Id;
232 Found : Boolean := False;
233 Element : Array_Element;
235 Spec_Str : String_Id;
236 Impl_Str : String_Id;
239 -- The following code is completely uncommented ???
241 Get_Name_String (Language);
242 Name_Buffer (1 .. Name_Len) := To_Lower (Name_Buffer (1 .. Name_Len));
245 Get_Name_String (Default_Spec_Suffix);
247 Store_String_Chars (Name_Buffer (1 .. Name_Len));
248 Spec_Str := End_String;
250 Get_Name_String (Default_Impl_Suffix);
252 Store_String_Chars (Name_Buffer (1 .. Name_Len));
253 Impl_Str := End_String;
255 Suffix := Std_Naming_Data.Specification_Suffix;
258 while Suffix /= No_Array_Element and then not Found loop
259 Element := Array_Elements.Table (Suffix);
261 if Element.Index = Lang then
263 Element.Value.Value := Spec_Str;
264 Array_Elements.Table (Suffix) := Element;
267 Suffix := Element.Next;
274 Value => (Kind => Single,
275 Location => No_Location,
278 Next => Std_Naming_Data.Specification_Suffix);
279 Array_Elements.Increment_Last;
280 Array_Elements.Table (Array_Elements.Last) := Element;
281 Std_Naming_Data.Specification_Suffix := Array_Elements.Last;
284 Suffix := Std_Naming_Data.Implementation_Suffix;
287 while Suffix /= No_Array_Element and then not Found loop
288 Element := Array_Elements.Table (Suffix);
290 if Element.Index = Lang then
292 Element.Value.Value := Impl_Str;
293 Array_Elements.Table (Suffix) := Element;
296 Suffix := Element.Next;
303 Value => (Kind => Single,
304 Location => No_Location,
307 Next => Std_Naming_Data.Implementation_Suffix);
308 Array_Elements.Increment_Last;
309 Array_Elements.Table (Array_Elements.Last) := Element;
310 Std_Naming_Data.Implementation_Suffix := Array_Elements.Last;
312 end Register_Default_Naming_Scheme;
324 Variable_Elements.Init;
325 String_Elements.Init;
327 Prj.Com.Units_Htable.Reset;
330 ------------------------
331 -- Same_Naming_Scheme --
332 ------------------------
334 function Same_Naming_Scheme
335 (Left, Right : Naming_Data)
339 return Left.Dot_Replacement = Right.Dot_Replacement
340 and then Left.Casing = Right.Casing
341 and then Left.Current_Spec_Suffix = Right.Current_Spec_Suffix
342 and then Left.Current_Impl_Suffix = Right.Current_Impl_Suffix
343 and then Left.Separate_Suffix = Right.Separate_Suffix;
344 end Same_Naming_Scheme;
354 -- Change operator symbol to literal strings, since that's the way
355 -- we treat all strings in a project file.
357 if Token = Tok_Operator_Symbol then
358 Sinfo.CN.Change_Operator_Symbol_To_String_Literal (Token_Node);
359 Token := Tok_String_Literal;
363 --------------------------
364 -- Standard_Naming_Data --
365 --------------------------
367 function Standard_Naming_Data return Naming_Data is
370 return Std_Naming_Data;
371 end Standard_Naming_Data;
377 function Value (Image : String) return Casing_Type is
379 for Casing in The_Casing_Images'Range loop
380 if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then
385 raise Constraint_Error;
389 -- Make sure that the standard project file extension is compatible
390 -- with canonical case file naming.
392 Canonical_Case_File_Name (Project_File_Extension);