1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2005 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, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, 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 Output; use Output;
31 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.Case_Util; use GNAT.Case_Util;
40 with GNAT.OS_Lib; use GNAT.OS_Lib;
44 Initial_Buffer_Size : constant := 100;
45 -- Initial size for extensible buffer used in Add_To_Buffer
47 The_Empty_String : Name_Id;
49 Name_C_Plus_Plus : Name_Id;
51 Default_Ada_Spec_Suffix_Id : Name_Id;
52 Default_Ada_Body_Suffix_Id : Name_Id;
54 -- Initialized in Prj.Initialized, then never modified
56 subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case;
58 The_Casing_Images : constant array (Known_Casing) of String_Access :=
59 (All_Lower_Case => new String'("lowercase"),
60 All_Upper_Case => new String'("UPPERCASE"),
61 Mixed_Case => new String'("MixedCase"));
63 Initialized : Boolean := False;
65 Standard_Dot_Replacement : constant Name_Id :=
66 First_Name_Id + Character'Pos ('-');
68 Std_Naming_Data : Naming_Data :=
69 (Dot_Replacement => Standard_Dot_Replacement,
70 Dot_Repl_Loc => No_Location,
71 Casing => All_Lower_Case,
72 Spec_Suffix => No_Array_Element,
73 Ada_Spec_Suffix => No_Name,
74 Spec_Suffix_Loc => No_Location,
75 Impl_Suffixes => No_Impl_Suffixes,
76 Supp_Suffixes => No_Supp_Language_Index,
77 Body_Suffix => No_Array_Element,
78 Ada_Body_Suffix => No_Name,
79 Body_Suffix_Loc => No_Location,
80 Separate_Suffix => No_Name,
81 Sep_Suffix_Loc => No_Location,
82 Specs => No_Array_Element,
83 Bodies => No_Array_Element,
84 Specification_Exceptions => No_Array_Element,
85 Implementation_Exceptions => No_Array_Element);
87 Project_Empty : Project_Data :=
88 (Externally_Built => False,
89 Languages => No_Languages,
90 Supp_Languages => No_Supp_Language_Index,
91 First_Referred_By => No_Project,
93 Display_Name => No_Name,
95 Display_Path_Name => No_Name,
97 Location => No_Location,
100 Display_Directory => No_Name,
103 Library_Dir => No_Name,
104 Display_Library_Dir => No_Name,
105 Library_Src_Dir => No_Name,
106 Display_Library_Src_Dir => No_Name,
107 Library_Name => No_Name,
108 Library_Kind => Static,
109 Lib_Internal_Name => No_Name,
110 Standalone_Library => False,
111 Lib_Interface_ALIs => Nil_String,
112 Lib_Auto_Init => False,
113 Symbol_Data => No_Symbols,
114 Ada_Sources_Present => True,
115 Other_Sources_Present => True,
116 Sources => Nil_String,
117 First_Other_Source => No_Other_Source,
118 Last_Other_Source => No_Other_Source,
119 Imported_Directories_Switches => null,
120 Include_Path => null,
121 Include_Data_Set => False,
122 Source_Dirs => Nil_String,
123 Known_Order_Of_Source_Dirs => True,
124 Object_Directory => No_Name,
125 Display_Object_Dir => No_Name,
126 Exec_Directory => No_Name,
127 Display_Exec_Dir => No_Name,
128 Extends => No_Project,
129 Extended_By => No_Project,
130 Naming => Std_Naming_Data,
131 First_Language_Processing => Default_First_Language_Processing_Data,
132 Supp_Language_Processing => No_Supp_Language_Index,
133 Default_Linker => No_Name,
134 Default_Linker_Path => No_Name,
135 Decl => No_Declarations,
136 Imported_Projects => Empty_Project_List,
137 Ada_Include_Path => null,
138 Ada_Objects_Path => null,
139 Include_Path_File => No_Name,
140 Objects_Path_File_With_Libs => No_Name,
141 Objects_Path_File_Without_Libs => No_Name,
142 Config_File_Name => No_Name,
143 Config_File_Temp => False,
144 Config_Checked => False,
145 Language_Independent_Checked => False,
148 Need_To_Build_Lib => False,
150 Unkept_Comments => False);
152 -----------------------
153 -- Add_Language_Name --
154 -----------------------
156 procedure Add_Language_Name (Name : Name_Id) is
158 Last_Language_Index := Last_Language_Index + 1;
159 Language_Indexes.Set (Name, Last_Language_Index);
160 Language_Names.Increment_Last;
161 Language_Names.Table (Last_Language_Index) := Name;
162 end Add_Language_Name;
168 procedure Add_To_Buffer
170 To : in out String_Access;
171 Last : in out Natural)
175 To := new String (1 .. Initial_Buffer_Size);
179 -- If Buffer is too small, double its size
181 while Last + S'Length > To'Last loop
183 New_Buffer : constant String_Access :=
184 new String (1 .. 2 * Last);
187 New_Buffer (1 .. Last) := To (1 .. Last);
193 To (Last + 1 .. Last + S'Length) := S;
194 Last := Last + S'Length;
197 -----------------------------
198 -- Default_Ada_Body_Suffix --
199 -----------------------------
201 function Default_Ada_Body_Suffix return Name_Id is
203 return Default_Ada_Body_Suffix_Id;
204 end Default_Ada_Body_Suffix;
206 -----------------------------
207 -- Default_Ada_Spec_Suffix --
208 -----------------------------
210 function Default_Ada_Spec_Suffix return Name_Id is
212 return Default_Ada_Spec_Suffix_Id;
213 end Default_Ada_Spec_Suffix;
215 ---------------------------
216 -- Display_Language_Name --
217 ---------------------------
219 procedure Display_Language_Name (Language : Language_Index) is
221 Get_Name_String (Language_Names.Table (Language));
222 To_Upper (Name_Buffer (1 .. 1));
223 Write_Str (Name_Buffer (1 .. Name_Len));
224 end Display_Language_Name;
230 function Empty_Project (Tree : Project_Tree_Ref) return Project_Data is
231 Value : Project_Data;
233 Prj.Initialize (Tree => No_Project_Tree);
234 Value := Project_Empty;
235 Value.Naming := Tree.Private_Part.Default_Naming;
243 function Empty_String return Name_Id is
245 return The_Empty_String;
252 procedure Expect (The_Token : Token_Type; Token_Image : String) is
254 if Token /= The_Token then
255 Error_Msg (Token_Image & " expected", Token_Ptr);
259 --------------------------------
260 -- For_Every_Project_Imported --
261 --------------------------------
263 procedure For_Every_Project_Imported
265 In_Tree : Project_Tree_Ref;
266 With_State : in out State)
269 procedure Recursive_Check (Project : Project_Id);
270 -- Check if a project has already been seen. If not seen, mark it as
271 -- Seen, Call Action, and check all its imported projects.
273 ---------------------
274 -- Recursive_Check --
275 ---------------------
277 procedure Recursive_Check (Project : Project_Id) is
281 if not In_Tree.Projects.Table (Project).Seen then
282 In_Tree.Projects.Table (Project).Seen := True;
283 Action (Project, With_State);
286 In_Tree.Projects.Table (Project).Imported_Projects;
287 while List /= Empty_Project_List loop
288 Recursive_Check (In_Tree.Project_Lists.Table (List).Project);
289 List := In_Tree.Project_Lists.Table (List).Next;
294 -- Start of processing for For_Every_Project_Imported
297 for Project in Project_Table.First ..
298 Project_Table.Last (In_Tree.Projects)
300 In_Tree.Projects.Table (Project).Seen := False;
303 Recursive_Check (Project => By);
304 end For_Every_Project_Imported;
310 function Hash (Name : Name_Id) return Header_Num is
312 return Hash (Get_Name_String (Name));
319 function Image (Casing : Casing_Type) return String is
321 return The_Casing_Images (Casing).all;
328 procedure Initialize (Tree : Project_Tree_Ref) is
330 if not Initialized then
334 The_Empty_String := Name_Find;
335 Empty_Name := The_Empty_String;
337 Name_Buffer (1 .. 4) := ".ads";
338 Default_Ada_Spec_Suffix_Id := Name_Find;
340 Name_Buffer (1 .. 4) := ".adb";
341 Default_Ada_Body_Suffix_Id := Name_Find;
343 Name_Buffer (1) := '/';
344 Slash_Id := Name_Find;
346 Name_Buffer (1 .. 3) := "c++";
347 Name_C_Plus_Plus := Name_Find;
349 Std_Naming_Data.Ada_Spec_Suffix := Default_Ada_Spec_Suffix;
350 Std_Naming_Data.Ada_Body_Suffix := Default_Ada_Body_Suffix;
351 Std_Naming_Data.Separate_Suffix := Default_Ada_Body_Suffix;
352 Project_Empty.Naming := Std_Naming_Data;
355 Set_Name_Table_Byte (Name_Project, Token_Type'Pos (Tok_Project));
356 Set_Name_Table_Byte (Name_Extends, Token_Type'Pos (Tok_Extends));
357 Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External));
359 Language_Indexes.Reset;
360 Last_Language_Index := No_Language_Index;
362 Add_Language_Name (Name_Ada);
363 Add_Language_Name (Name_C);
364 Add_Language_Name (Name_C_Plus_Plus);
367 if Tree /= No_Project_Tree then
377 (Language : Language_Index;
378 In_Project : Project_Data;
379 In_Tree : Project_Tree_Ref) return Boolean
383 when No_Language_Index =>
386 when First_Language_Indexes =>
387 return In_Project.Languages (Language);
391 Supp : Supp_Language;
392 Supp_Index : Supp_Language_Index := In_Project.Supp_Languages;
395 while Supp_Index /= No_Supp_Language_Index loop
396 Supp := In_Tree.Present_Languages.Table (Supp_Index);
398 if Supp.Index = Language then
402 Supp_Index := Supp.Next;
410 ---------------------------------
411 -- Language_Processing_Data_Of --
412 ---------------------------------
414 function Language_Processing_Data_Of
415 (Language : Language_Index;
416 In_Project : Project_Data;
417 In_Tree : Project_Tree_Ref) return Language_Processing_Data
421 when No_Language_Index =>
422 return Default_Language_Processing_Data;
424 when First_Language_Indexes =>
425 return In_Project.First_Language_Processing (Language);
429 Supp : Supp_Language_Data;
430 Supp_Index : Supp_Language_Index :=
431 In_Project.Supp_Language_Processing;
434 while Supp_Index /= No_Supp_Language_Index loop
435 Supp := In_Tree.Supp_Languages.Table (Supp_Index);
437 if Supp.Index = Language then
441 Supp_Index := Supp.Next;
444 return Default_Language_Processing_Data;
447 end Language_Processing_Data_Of;
449 ------------------------------------
450 -- Register_Default_Naming_Scheme --
451 ------------------------------------
453 procedure Register_Default_Naming_Scheme
455 Default_Spec_Suffix : Name_Id;
456 Default_Body_Suffix : Name_Id;
457 In_Tree : Project_Tree_Ref)
460 Suffix : Array_Element_Id;
461 Found : Boolean := False;
462 Element : Array_Element;
465 -- Get the language name in small letters
467 Get_Name_String (Language);
468 Name_Buffer (1 .. Name_Len) := To_Lower (Name_Buffer (1 .. Name_Len));
471 Suffix := In_Tree.Private_Part.Default_Naming.Spec_Suffix;
474 -- Look for an element of the spec sufix array indexed by the language
475 -- name. If one is found, put the default value.
477 while Suffix /= No_Array_Element and then not Found loop
478 Element := In_Tree.Array_Elements.Table (Suffix);
480 if Element.Index = Lang then
482 Element.Value.Value := Default_Spec_Suffix;
483 In_Tree.Array_Elements.Table (Suffix) := Element;
486 Suffix := Element.Next;
490 -- If none can be found, create a new one.
496 Index_Case_Sensitive => False,
497 Value => (Project => No_Project,
499 Location => No_Location,
501 Value => Default_Spec_Suffix,
503 Next => In_Tree.Private_Part.Default_Naming.Spec_Suffix);
504 Array_Element_Table.Increment_Last (In_Tree.Array_Elements);
505 In_Tree.Array_Elements.Table
506 (Array_Element_Table.Last (In_Tree.Array_Elements)) :=
508 In_Tree.Private_Part.Default_Naming.Spec_Suffix :=
509 Array_Element_Table.Last (In_Tree.Array_Elements);
512 Suffix := In_Tree.Private_Part.Default_Naming.Body_Suffix;
515 -- Look for an element of the body sufix array indexed by the language
516 -- name. If one is found, put the default value.
518 while Suffix /= No_Array_Element and then not Found loop
519 Element := In_Tree.Array_Elements.Table (Suffix);
521 if Element.Index = Lang then
523 Element.Value.Value := Default_Body_Suffix;
524 In_Tree.Array_Elements.Table (Suffix) := Element;
527 Suffix := Element.Next;
531 -- If none can be found, create a new one.
537 Index_Case_Sensitive => False,
538 Value => (Project => No_Project,
540 Location => No_Location,
542 Value => Default_Body_Suffix,
544 Next => In_Tree.Private_Part.Default_Naming.Body_Suffix);
545 Array_Element_Table.Increment_Last
546 (In_Tree.Array_Elements);
547 In_Tree.Array_Elements.Table
548 (Array_Element_Table.Last (In_Tree.Array_Elements))
550 In_Tree.Private_Part.Default_Naming.Body_Suffix :=
551 Array_Element_Table.Last (In_Tree.Array_Elements);
553 end Register_Default_Naming_Scheme;
559 procedure Reset (Tree : Project_Tree_Ref) is
562 Present_Language_Table.Init (Tree.Present_Languages);
563 Supp_Suffix_Table.Init (Tree.Supp_Suffixes);
564 Name_List_Table.Init (Tree.Name_Lists);
565 Supp_Language_Table.Init (Tree.Supp_Languages);
566 Other_Source_Table.Init (Tree.Other_Sources);
567 String_Element_Table.Init (Tree.String_Elements);
568 Variable_Element_Table.Init (Tree.Variable_Elements);
569 Array_Element_Table.Init (Tree.Array_Elements);
570 Array_Table.Init (Tree.Arrays);
571 Package_Table.Init (Tree.Packages);
572 Project_List_Table.Init (Tree.Project_Lists);
573 Project_Table.Init (Tree.Projects);
574 Unit_Table.Init (Tree.Units);
575 Units_Htable.Reset (Tree.Units_HT);
576 Files_Htable.Reset (Tree.Files_HT);
577 Naming_Table.Init (Tree.Private_Part.Namings);
578 Path_File_Table.Init (Tree.Private_Part.Path_Files);
579 Source_Path_Table.Init (Tree.Private_Part.Source_Paths);
580 Object_Path_Table.Init (Tree.Private_Part.Object_Paths);
581 Tree.Private_Part.Default_Naming := Std_Naming_Data;
582 Register_Default_Naming_Scheme
583 (Language => Name_Ada,
584 Default_Spec_Suffix => Default_Ada_Spec_Suffix,
585 Default_Body_Suffix => Default_Ada_Body_Suffix,
589 ------------------------
590 -- Same_Naming_Scheme --
591 ------------------------
593 function Same_Naming_Scheme
594 (Left, Right : Naming_Data) return Boolean
597 return Left.Dot_Replacement = Right.Dot_Replacement
598 and then Left.Casing = Right.Casing
599 and then Left.Ada_Spec_Suffix = Right.Ada_Spec_Suffix
600 and then Left.Ada_Body_Suffix = Right.Ada_Body_Suffix
601 and then Left.Separate_Suffix = Right.Separate_Suffix;
602 end Same_Naming_Scheme;
609 (Language : Language_Index;
611 In_Project : in out Project_Data;
612 In_Tree : Project_Tree_Ref)
616 when No_Language_Index =>
619 when First_Language_Indexes =>
620 In_Project.Languages (Language) := Present;
624 Supp : Supp_Language;
625 Supp_Index : Supp_Language_Index := In_Project.Supp_Languages;
628 while Supp_Index /= No_Supp_Language_Index loop
629 Supp := In_Tree.Present_Languages.Table
632 if Supp.Index = Language then
633 In_Tree.Present_Languages.Table
634 (Supp_Index).Present := Present;
638 Supp_Index := Supp.Next;
641 Supp := (Index => Language, Present => Present,
642 Next => In_Project.Supp_Languages);
643 Present_Language_Table.Increment_Last
644 (In_Tree.Present_Languages);
645 Supp_Index := Present_Language_Table.Last
646 (In_Tree.Present_Languages);
647 In_Tree.Present_Languages.Table (Supp_Index) :=
649 In_Project.Supp_Languages := Supp_Index;
655 (Language_Processing : Language_Processing_Data;
656 For_Language : Language_Index;
657 In_Project : in out Project_Data;
658 In_Tree : Project_Tree_Ref)
662 when No_Language_Index =>
665 when First_Language_Indexes =>
666 In_Project.First_Language_Processing (For_Language) :=
671 Supp : Supp_Language_Data;
672 Supp_Index : Supp_Language_Index :=
673 In_Project.Supp_Language_Processing;
676 while Supp_Index /= No_Supp_Language_Index loop
677 Supp := In_Tree.Supp_Languages.Table (Supp_Index);
679 if Supp.Index = For_Language then
680 In_Tree.Supp_Languages.Table
681 (Supp_Index).Data := Language_Processing;
685 Supp_Index := Supp.Next;
688 Supp := (Index => For_Language, Data => Language_Processing,
689 Next => In_Project.Supp_Language_Processing);
690 Supp_Language_Table.Increment_Last
691 (In_Tree.Supp_Languages);
692 Supp_Index := Supp_Language_Table.Last
693 (In_Tree.Supp_Languages);
694 In_Tree.Supp_Languages.Table (Supp_Index) := Supp;
695 In_Project.Supp_Language_Processing := Supp_Index;
702 For_Language : Language_Index;
703 In_Project : in out Project_Data;
704 In_Tree : Project_Tree_Ref)
708 when No_Language_Index =>
711 when First_Language_Indexes =>
712 In_Project.Naming.Impl_Suffixes (For_Language) := Suffix;
717 Supp_Index : Supp_Language_Index :=
718 In_Project.Naming.Supp_Suffixes;
721 while Supp_Index /= No_Supp_Language_Index loop
722 Supp := In_Tree.Supp_Suffixes.Table
725 if Supp.Index = For_Language then
726 In_Tree.Supp_Suffixes.Table
727 (Supp_Index).Suffix := Suffix;
731 Supp_Index := Supp.Next;
734 Supp := (Index => For_Language, Suffix => Suffix,
735 Next => In_Project.Naming.Supp_Suffixes);
736 Supp_Suffix_Table.Increment_Last
737 (In_Tree.Supp_Suffixes);
738 Supp_Index := Supp_Suffix_Table.Last
739 (In_Tree.Supp_Suffixes);
740 In_Tree.Supp_Suffixes.Table (Supp_Index) := Supp;
741 In_Project.Naming.Supp_Suffixes := Supp_Index;
750 function Slash return Name_Id is
755 --------------------------
756 -- Standard_Naming_Data --
757 --------------------------
759 function Standard_Naming_Data
760 (Tree : Project_Tree_Ref := No_Project_Tree) return Naming_Data
763 if Tree = No_Project_Tree then
764 Prj.Initialize (Tree => No_Project_Tree);
765 return Std_Naming_Data;
768 return Tree.Private_Part.Default_Naming;
770 end Standard_Naming_Data;
777 (Language : Language_Index;
778 In_Project : Project_Data;
779 In_Tree : Project_Tree_Ref) return Name_Id
783 when No_Language_Index =>
786 when First_Language_Indexes =>
787 return In_Project.Naming.Impl_Suffixes (Language);
792 Supp_Index : Supp_Language_Index :=
793 In_Project.Naming.Supp_Suffixes;
796 while Supp_Index /= No_Supp_Language_Index loop
797 Supp := In_Tree.Supp_Suffixes.Table (Supp_Index);
799 if Supp.Index = Language then
803 Supp_Index := Supp.Next;
815 function Value (Image : String) return Casing_Type is
817 for Casing in The_Casing_Images'Range loop
818 if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then
823 raise Constraint_Error;
827 -- Make sure that the standard project file extension is compatible
828 -- with canonical case file naming.
830 Canonical_Case_File_Name (Project_File_Extension);