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;
36 with Scans; use Scans;
38 with Stringt; use Stringt;
40 with Snames; use Snames;
44 The_Empty_String : String_Id;
46 subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case;
48 The_Casing_Images : 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 Specification_Suffix => No_Array_Element,
64 Current_Spec_Suffix => No_Name,
65 Spec_Suffix_Loc => No_Location,
66 Implementation_Suffix => No_Array_Element,
67 Current_Impl_Suffix => No_Name,
68 Impl_Suffix_Loc => No_Location,
69 Separate_Suffix => No_Name,
70 Sep_Suffix_Loc => No_Location,
71 Specifications => 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,
80 Location => No_Location,
83 Library_Dir => No_Name,
84 Library_Name => No_Name,
85 Library_Kind => Static,
86 Lib_Internal_Name => No_Name,
87 Lib_Elaboration => False,
88 Sources_Present => True,
89 Sources => Nil_String,
90 Source_Dirs => Nil_String,
91 Object_Directory => No_Name,
92 Exec_Directory => No_Name,
93 Modifies => No_Project,
94 Modified_By => No_Project,
95 Naming => Std_Naming_Data,
96 Decl => No_Declarations,
97 Imported_Projects => Empty_Project_List,
100 Config_File_Name => No_Name,
101 Config_File_Temp => False,
102 Config_Checked => False,
103 Language_Independent_Checked => False,
113 function Empty_Project return Project_Data is
116 return Project_Empty;
123 function Empty_String return String_Id is
125 return The_Empty_String;
132 procedure Expect (The_Token : Token_Type; Token_Image : String) is
134 if Token /= The_Token then
135 Error_Msg ("""" & Token_Image & """ expected", Token_Ptr);
139 --------------------------------
140 -- For_Every_Project_Imported --
141 --------------------------------
143 procedure For_Every_Project_Imported
145 With_State : in out State)
148 procedure Check (Project : Project_Id);
149 -- Check if a project has already been seen.
150 -- If not seen, mark it as seen, call Action,
151 -- and check all its imported projects.
153 procedure Check (Project : Project_Id) is
157 if not Projects.Table (Project).Seen then
158 Projects.Table (Project).Seen := False;
159 Action (Project, With_State);
161 List := Projects.Table (Project).Imported_Projects;
162 while List /= Empty_Project_List loop
163 Check (Project_Lists.Table (List).Project);
164 List := Project_Lists.Table (List).Next;
170 for Project in Projects.First .. Projects.Last loop
171 Projects.Table (Project).Seen := False;
174 Check (Project => By);
175 end For_Every_Project_Imported;
181 function Image (Casing : Casing_Type) return String is
183 return The_Casing_Images (Casing).all;
190 procedure Initialize is
192 if not Initialized then
196 The_Empty_String := End_String;
198 Name_Buffer (1 .. 4) := ".ads";
199 Default_Ada_Spec_Suffix := Name_Find;
201 Name_Buffer (1 .. 4) := ".adb";
202 Default_Ada_Impl_Suffix := Name_Find;
203 Std_Naming_Data.Current_Spec_Suffix := Default_Ada_Spec_Suffix;
204 Std_Naming_Data.Current_Impl_Suffix := Default_Ada_Impl_Suffix;
205 Std_Naming_Data.Separate_Suffix := Default_Ada_Impl_Suffix;
208 Set_Name_Table_Byte (Name_Project, Token_Type'Pos (Tok_Project));
209 Set_Name_Table_Byte (Name_Extends, Token_Type'Pos (Tok_Extends));
210 Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External));
224 Variable_Elements.Init;
225 String_Elements.Init;
227 Prj.Com.Units_Htable.Reset;
230 ------------------------
231 -- Same_Naming_Scheme --
232 ------------------------
234 function Same_Naming_Scheme
235 (Left, Right : Naming_Data)
239 return Left.Dot_Replacement = Right.Dot_Replacement
240 and then Left.Casing = Right.Casing
241 and then Left.Current_Spec_Suffix = Right.Current_Spec_Suffix
242 and then Left.Current_Impl_Suffix = Right.Current_Impl_Suffix
243 and then Left.Separate_Suffix = Right.Separate_Suffix;
244 end Same_Naming_Scheme;
254 -- Change operator symbol to literal strings, since that's the way
255 -- we treat all strings in a project file.
257 if Token = Tok_Operator_Symbol then
258 Sinfo.CN.Change_Operator_Symbol_To_String_Literal (Token_Node);
259 Token := Tok_String_Literal;
263 --------------------------
264 -- Standard_Naming_Data --
265 --------------------------
267 function Standard_Naming_Data return Naming_Data is
270 return Std_Naming_Data;
271 end Standard_Naming_Data;
277 function Value (Image : String) return Casing_Type is
279 for Casing in The_Casing_Images'Range loop
280 if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then
285 raise Constraint_Error;