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 subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case;
49 The_Casing_Images : array (Known_Casing) of String_Access :=
50 (All_Lower_Case => new String'("lowercase"),
51 All_Upper_Case => new String'("UPPERCASE"),
52 Mixed_Case => new String'("MixedCase"));
54 Initialized : Boolean := False;
56 Standard_Dot_Replacement : constant Name_Id :=
57 First_Name_Id + Character'Pos ('-');
58 Standard_Specification_Append : Name_Id;
59 Standard_Body_Append : Name_Id;
61 Std_Naming_Data : Naming_Data :=
62 (Dot_Replacement => Standard_Dot_Replacement,
63 Dot_Repl_Loc => No_Location,
64 Casing => All_Lower_Case,
65 Specification_Append => No_Name,
66 Spec_Append_Loc => No_Location,
67 Body_Append => No_Name,
68 Body_Append_Loc => No_Location,
69 Separate_Append => No_Name,
70 Sep_Append_Loc => No_Location,
71 Specifications => No_Array_Element,
72 Bodies => No_Array_Element);
74 Project_Empty : Project_Data :=
75 (First_Referred_By => No_Project,
78 Location => No_Location,
82 Library_Dir => No_Name,
83 Library_Name => No_Name,
84 Library_Kind => Static,
85 Lib_Internal_Name => No_Name,
86 Lib_Elaboration => False,
87 Sources => Nil_String,
88 Source_Dirs => Nil_String,
89 Object_Directory => No_Name,
90 Modifies => No_Project,
91 Modified_By => No_Project,
92 Naming => Std_Naming_Data,
93 Decl => No_Declarations,
94 Imported_Projects => Empty_Project_List,
97 Config_File_Name => No_Name,
98 Config_File_Temp => False,
99 Config_Checked => False,
109 function Empty_Project return Project_Data is
112 return Project_Empty;
119 function Empty_String return String_Id is
121 return The_Empty_String;
128 procedure Expect (The_Token : Token_Type; Token_Image : String) is
130 if Token /= The_Token then
131 Error_Msg ("""" & Token_Image & """ expected", Token_Ptr);
135 --------------------------------
136 -- For_Every_Project_Imported --
137 --------------------------------
139 procedure For_Every_Project_Imported
141 With_State : in out State)
144 procedure Check (Project : Project_Id);
145 -- Check if a project has already been seen.
146 -- If not seen, mark it as seen, call Action,
147 -- and check all its imported projects.
149 procedure Check (Project : Project_Id) is
153 if not Projects.Table (Project).Seen then
154 Projects.Table (Project).Seen := False;
155 Action (Project, With_State);
157 List := Projects.Table (Project).Imported_Projects;
158 while List /= Empty_Project_List loop
159 Check (Project_Lists.Table (List).Project);
160 List := Project_Lists.Table (List).Next;
166 for Project in Projects.First .. Projects.Last loop
167 Projects.Table (Project).Seen := False;
170 Check (Project => By);
171 end For_Every_Project_Imported;
177 function Image (Casing : Casing_Type) return String is
179 return The_Casing_Images (Casing).all;
186 procedure Initialize is
188 if not Initialized then
192 The_Empty_String := End_String;
194 Name_Buffer (1 .. 4) := ".ads";
195 Canonical_Case_File_Name (Name_Buffer (1 .. 4));
196 Standard_Specification_Append := Name_Find;
197 Name_Buffer (4) := 'b';
198 Canonical_Case_File_Name (Name_Buffer (1 .. 4));
199 Standard_Body_Append := Name_Find;
200 Std_Naming_Data.Specification_Append := Standard_Specification_Append;
201 Std_Naming_Data.Body_Append := Standard_Body_Append;
202 Std_Naming_Data.Separate_Append := Standard_Body_Append;
203 Project_Empty.Naming := Std_Naming_Data;
206 Set_Name_Table_Byte (Name_Project, Token_Type'Pos (Tok_Project));
207 Set_Name_Table_Byte (Name_Modifying, Token_Type'Pos (Tok_Modifying));
208 Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External));
222 Variable_Elements.Init;
223 String_Elements.Init;
225 Prj.Com.Units_Htable.Reset;
228 ------------------------
229 -- Same_Naming_Scheme --
230 ------------------------
232 function Same_Naming_Scheme
233 (Left, Right : Naming_Data)
237 return Left.Dot_Replacement = Right.Dot_Replacement
238 and then Left.Casing = Right.Casing
239 and then Left.Specification_Append = Right.Specification_Append
240 and then Left.Body_Append = Right.Body_Append
241 and then Left.Separate_Append = Right.Separate_Append;
242 end Same_Naming_Scheme;
252 -- Change operator symbol to literal strings, since that's the way
253 -- we treat all strings in a project file.
255 if Token = Tok_Operator_Symbol then
256 Sinfo.CN.Change_Operator_Symbol_To_String_Literal (Token_Node);
257 Token := Tok_String_Literal;
261 --------------------------
262 -- Standard_Naming_Data --
263 --------------------------
265 function Standard_Naming_Data return Naming_Data is
268 return Std_Naming_Data;
269 end Standard_Naming_Data;
275 function Value (Image : String) return Casing_Type is
277 for Casing in The_Casing_Images'Range loop
278 if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then
283 raise Constraint_Error;