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, 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 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,
94 Display_Path_Name => No_Name,
96 Location => No_Location,
99 Display_Directory => No_Name,
102 Library_Dir => No_Name,
103 Display_Library_Dir => No_Name,
104 Library_Src_Dir => No_Name,
105 Display_Library_Src_Dir => No_Name,
106 Library_Name => No_Name,
107 Library_Kind => Static,
108 Lib_Internal_Name => No_Name,
109 Standalone_Library => False,
110 Lib_Interface_ALIs => Nil_String,
111 Lib_Auto_Init => False,
112 Symbol_Data => No_Symbols,
113 Ada_Sources_Present => True,
114 Other_Sources_Present => True,
115 Sources => Nil_String,
116 First_Other_Source => No_Other_Source,
117 Last_Other_Source => No_Other_Source,
118 Imported_Directories_Switches => null,
119 Include_Path => null,
120 Include_Data_Set => False,
121 Source_Dirs => Nil_String,
122 Known_Order_Of_Source_Dirs => True,
123 Object_Directory => No_Name,
124 Display_Object_Dir => No_Name,
125 Exec_Directory => No_Name,
126 Display_Exec_Dir => No_Name,
127 Extends => No_Project,
128 Extended_By => No_Project,
129 Naming => Std_Naming_Data,
130 First_Language_Processing => Default_First_Language_Processing_Data,
131 Supp_Language_Processing => No_Supp_Language_Index,
132 Default_Linker => No_Name,
133 Default_Linker_Path => No_Name,
134 Decl => No_Declarations,
135 Imported_Projects => Empty_Project_List,
136 Ada_Include_Path => null,
137 Ada_Objects_Path => null,
138 Include_Path_File => No_Name,
139 Objects_Path_File_With_Libs => No_Name,
140 Objects_Path_File_Without_Libs => No_Name,
141 Config_File_Name => No_Name,
142 Config_File_Temp => False,
143 Config_Checked => False,
144 Language_Independent_Checked => False,
147 Need_To_Build_Lib => False,
149 Unkept_Comments => False);
151 -----------------------
152 -- Add_Language_Name --
153 -----------------------
155 procedure Add_Language_Name (Name : Name_Id) is
157 Last_Language_Index := Last_Language_Index + 1;
158 Language_Indexes.Set (Name, Last_Language_Index);
159 Language_Names.Increment_Last;
160 Language_Names.Table (Last_Language_Index) := Name;
161 end Add_Language_Name;
167 procedure Add_To_Buffer
169 To : in out String_Access;
170 Last : in out Natural)
174 To := new String (1 .. Initial_Buffer_Size);
178 -- If Buffer is too small, double its size
180 while Last + S'Length > To'Last loop
182 New_Buffer : constant String_Access :=
183 new String (1 .. 2 * Last);
186 New_Buffer (1 .. Last) := To (1 .. Last);
192 To (Last + 1 .. Last + S'Length) := S;
193 Last := Last + S'Length;
196 -----------------------------
197 -- Default_Ada_Body_Suffix --
198 -----------------------------
200 function Default_Ada_Body_Suffix return Name_Id is
202 return Default_Ada_Body_Suffix_Id;
203 end Default_Ada_Body_Suffix;
205 -----------------------------
206 -- Default_Ada_Spec_Suffix --
207 -----------------------------
209 function Default_Ada_Spec_Suffix return Name_Id is
211 return Default_Ada_Spec_Suffix_Id;
212 end Default_Ada_Spec_Suffix;
214 ---------------------------
215 -- Display_Language_Name --
216 ---------------------------
218 procedure Display_Language_Name (Language : Language_Index) is
220 Get_Name_String (Language_Names.Table (Language));
221 To_Upper (Name_Buffer (1 .. 1));
222 Write_Str (Name_Buffer (1 .. Name_Len));
223 end Display_Language_Name;
229 function Empty_Project (Tree : Project_Tree_Ref) return Project_Data is
230 Value : Project_Data := Project_Empty;
232 Prj.Initialize (Tree => No_Project_Tree);
233 Value.Naming := Tree.Private_Part.Default_Naming;
241 function Empty_String return Name_Id is
243 return The_Empty_String;
250 procedure Expect (The_Token : Token_Type; Token_Image : String) is
252 if Token /= The_Token then
253 Error_Msg (Token_Image & " expected", Token_Ptr);
257 --------------------------------
258 -- For_Every_Project_Imported --
259 --------------------------------
261 procedure For_Every_Project_Imported
263 In_Tree : Project_Tree_Ref;
264 With_State : in out State)
267 procedure Recursive_Check (Project : Project_Id);
268 -- Check if a project has already been seen. If not seen, mark it as
269 -- Seen, Call Action, and check all its imported projects.
271 ---------------------
272 -- Recursive_Check --
273 ---------------------
275 procedure Recursive_Check (Project : Project_Id) is
279 if not In_Tree.Projects.Table (Project).Seen then
280 In_Tree.Projects.Table (Project).Seen := True;
281 Action (Project, With_State);
284 In_Tree.Projects.Table (Project).Imported_Projects;
285 while List /= Empty_Project_List loop
286 Recursive_Check (In_Tree.Project_Lists.Table (List).Project);
287 List := In_Tree.Project_Lists.Table (List).Next;
292 -- Start of processing for For_Every_Project_Imported
295 for Project in Project_Table.First ..
296 Project_Table.Last (In_Tree.Projects)
298 In_Tree.Projects.Table (Project).Seen := False;
301 Recursive_Check (Project => By);
302 end For_Every_Project_Imported;
308 function Hash (Name : Name_Id) return Header_Num is
310 return Hash (Get_Name_String (Name));
317 function Image (Casing : Casing_Type) return String is
319 return The_Casing_Images (Casing).all;
326 procedure Initialize (Tree : Project_Tree_Ref) is
328 if not Initialized then
332 The_Empty_String := Name_Find;
333 Empty_Name := The_Empty_String;
335 Name_Buffer (1 .. 4) := ".ads";
336 Default_Ada_Spec_Suffix_Id := Name_Find;
338 Name_Buffer (1 .. 4) := ".adb";
339 Default_Ada_Body_Suffix_Id := Name_Find;
341 Name_Buffer (1) := '/';
342 Slash_Id := Name_Find;
344 Name_Buffer (1 .. 3) := "c++";
345 Name_C_Plus_Plus := Name_Find;
347 Std_Naming_Data.Ada_Spec_Suffix := Default_Ada_Spec_Suffix;
348 Std_Naming_Data.Ada_Body_Suffix := Default_Ada_Body_Suffix;
349 Std_Naming_Data.Separate_Suffix := Default_Ada_Body_Suffix;
350 Project_Empty.Naming := Std_Naming_Data;
353 Set_Name_Table_Byte (Name_Project, Token_Type'Pos (Tok_Project));
354 Set_Name_Table_Byte (Name_Extends, Token_Type'Pos (Tok_Extends));
355 Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External));
357 Language_Indexes.Reset;
358 Last_Language_Index := No_Language_Index;
360 Add_Language_Name (Name_Ada);
361 Add_Language_Name (Name_C);
362 Add_Language_Name (Name_C_Plus_Plus);
365 if Tree /= No_Project_Tree then
375 (Language : Language_Index;
376 In_Project : Project_Data;
377 In_Tree : Project_Tree_Ref) return Boolean
381 when No_Language_Index =>
384 when First_Language_Indexes =>
385 return In_Project.Languages (Language);
389 Supp : Supp_Language;
390 Supp_Index : Supp_Language_Index := In_Project.Supp_Languages;
393 while Supp_Index /= No_Supp_Language_Index loop
394 Supp := In_Tree.Present_Languages.Table (Supp_Index);
396 if Supp.Index = Language then
400 Supp_Index := Supp.Next;
408 ---------------------------------
409 -- Language_Processing_Data_Of --
410 ---------------------------------
412 function Language_Processing_Data_Of
413 (Language : Language_Index;
414 In_Project : Project_Data;
415 In_Tree : Project_Tree_Ref) return Language_Processing_Data
419 when No_Language_Index =>
420 return Default_Language_Processing_Data;
422 when First_Language_Indexes =>
423 return In_Project.First_Language_Processing (Language);
427 Supp : Supp_Language_Data;
428 Supp_Index : Supp_Language_Index :=
429 In_Project.Supp_Language_Processing;
432 while Supp_Index /= No_Supp_Language_Index loop
433 Supp := In_Tree.Supp_Languages.Table (Supp_Index);
435 if Supp.Index = Language then
439 Supp_Index := Supp.Next;
442 return Default_Language_Processing_Data;
445 end Language_Processing_Data_Of;
447 ------------------------------------
448 -- Register_Default_Naming_Scheme --
449 ------------------------------------
451 procedure Register_Default_Naming_Scheme
453 Default_Spec_Suffix : Name_Id;
454 Default_Body_Suffix : Name_Id;
455 In_Tree : Project_Tree_Ref)
458 Suffix : Array_Element_Id;
459 Found : Boolean := False;
460 Element : Array_Element;
463 -- Get the language name in small letters
465 Get_Name_String (Language);
466 Name_Buffer (1 .. Name_Len) := To_Lower (Name_Buffer (1 .. Name_Len));
469 Suffix := In_Tree.Private_Part.Default_Naming.Spec_Suffix;
472 -- Look for an element of the spec sufix array indexed by the language
473 -- name. If one is found, put the default value.
475 while Suffix /= No_Array_Element and then not Found loop
476 Element := In_Tree.Array_Elements.Table (Suffix);
478 if Element.Index = Lang then
480 Element.Value.Value := Default_Spec_Suffix;
481 In_Tree.Array_Elements.Table (Suffix) := Element;
484 Suffix := Element.Next;
488 -- If none can be found, create a new one.
494 Index_Case_Sensitive => False,
495 Value => (Project => No_Project,
497 Location => No_Location,
499 Value => Default_Spec_Suffix,
501 Next => In_Tree.Private_Part.Default_Naming.Spec_Suffix);
502 Array_Element_Table.Increment_Last (In_Tree.Array_Elements);
503 In_Tree.Array_Elements.Table
504 (Array_Element_Table.Last (In_Tree.Array_Elements)) :=
506 In_Tree.Private_Part.Default_Naming.Spec_Suffix :=
507 Array_Element_Table.Last (In_Tree.Array_Elements);
510 Suffix := In_Tree.Private_Part.Default_Naming.Body_Suffix;
513 -- Look for an element of the body sufix array indexed by the language
514 -- name. If one is found, put the default value.
516 while Suffix /= No_Array_Element and then not Found loop
517 Element := In_Tree.Array_Elements.Table (Suffix);
519 if Element.Index = Lang then
521 Element.Value.Value := Default_Body_Suffix;
522 In_Tree.Array_Elements.Table (Suffix) := Element;
525 Suffix := Element.Next;
529 -- If none can be found, create a new one.
535 Index_Case_Sensitive => False,
536 Value => (Project => No_Project,
538 Location => No_Location,
540 Value => Default_Body_Suffix,
542 Next => In_Tree.Private_Part.Default_Naming.Body_Suffix);
543 Array_Element_Table.Increment_Last
544 (In_Tree.Array_Elements);
545 In_Tree.Array_Elements.Table
546 (Array_Element_Table.Last (In_Tree.Array_Elements))
548 In_Tree.Private_Part.Default_Naming.Body_Suffix :=
549 Array_Element_Table.Last (In_Tree.Array_Elements);
551 end Register_Default_Naming_Scheme;
557 procedure Reset (Tree : Project_Tree_Ref) is
560 Present_Language_Table.Init (Tree.Present_Languages);
561 Supp_Suffix_Table.Init (Tree.Supp_Suffixes);
562 Name_List_Table.Init (Tree.Name_Lists);
563 Supp_Language_Table.Init (Tree.Supp_Languages);
564 Other_Source_Table.Init (Tree.Other_Sources);
565 String_Element_Table.Init (Tree.String_Elements);
566 Variable_Element_Table.Init (Tree.Variable_Elements);
567 Array_Element_Table.Init (Tree.Array_Elements);
568 Array_Table.Init (Tree.Arrays);
569 Package_Table.Init (Tree.Packages);
570 Project_List_Table.Init (Tree.Project_Lists);
571 Project_Table.Init (Tree.Projects);
572 Unit_Table.Init (Tree.Units);
573 Units_Htable.Reset (Tree.Units_HT);
574 Files_Htable.Reset (Tree.Files_HT);
575 Naming_Table.Init (Tree.Private_Part.Namings);
576 Path_File_Table.Init (Tree.Private_Part.Path_Files);
577 Source_Path_Table.Init (Tree.Private_Part.Source_Paths);
578 Object_Path_Table.Init (Tree.Private_Part.Object_Paths);
579 Tree.Private_Part.Default_Naming := Std_Naming_Data;
580 Register_Default_Naming_Scheme
581 (Language => Name_Ada,
582 Default_Spec_Suffix => Default_Ada_Spec_Suffix,
583 Default_Body_Suffix => Default_Ada_Body_Suffix,
587 ------------------------
588 -- Same_Naming_Scheme --
589 ------------------------
591 function Same_Naming_Scheme
592 (Left, Right : Naming_Data) return Boolean
595 return Left.Dot_Replacement = Right.Dot_Replacement
596 and then Left.Casing = Right.Casing
597 and then Left.Ada_Spec_Suffix = Right.Ada_Spec_Suffix
598 and then Left.Ada_Body_Suffix = Right.Ada_Body_Suffix
599 and then Left.Separate_Suffix = Right.Separate_Suffix;
600 end Same_Naming_Scheme;
607 (Language : Language_Index;
609 In_Project : in out Project_Data;
610 In_Tree : Project_Tree_Ref)
614 when No_Language_Index =>
617 when First_Language_Indexes =>
618 In_Project.Languages (Language) := Present;
622 Supp : Supp_Language;
623 Supp_Index : Supp_Language_Index := In_Project.Supp_Languages;
626 while Supp_Index /= No_Supp_Language_Index loop
627 Supp := In_Tree.Present_Languages.Table
630 if Supp.Index = Language then
631 In_Tree.Present_Languages.Table
632 (Supp_Index).Present := Present;
636 Supp_Index := Supp.Next;
639 Supp := (Index => Language, Present => Present,
640 Next => In_Project.Supp_Languages);
641 Present_Language_Table.Increment_Last
642 (In_Tree.Present_Languages);
643 Supp_Index := Present_Language_Table.Last
644 (In_Tree.Present_Languages);
645 In_Tree.Present_Languages.Table (Supp_Index) :=
647 In_Project.Supp_Languages := Supp_Index;
653 (Language_Processing : Language_Processing_Data;
654 For_Language : Language_Index;
655 In_Project : in out Project_Data;
656 In_Tree : Project_Tree_Ref)
660 when No_Language_Index =>
663 when First_Language_Indexes =>
664 In_Project.First_Language_Processing (For_Language) :=
669 Supp : Supp_Language_Data;
670 Supp_Index : Supp_Language_Index :=
671 In_Project.Supp_Language_Processing;
674 while Supp_Index /= No_Supp_Language_Index loop
675 Supp := In_Tree.Supp_Languages.Table (Supp_Index);
677 if Supp.Index = For_Language then
678 In_Tree.Supp_Languages.Table
679 (Supp_Index).Data := Language_Processing;
683 Supp_Index := Supp.Next;
686 Supp := (Index => For_Language, Data => Language_Processing,
687 Next => In_Project.Supp_Language_Processing);
688 Supp_Language_Table.Increment_Last
689 (In_Tree.Supp_Languages);
690 Supp_Index := Supp_Language_Table.Last
691 (In_Tree.Supp_Languages);
692 In_Tree.Supp_Languages.Table (Supp_Index) := Supp;
693 In_Project.Supp_Language_Processing := Supp_Index;
700 For_Language : Language_Index;
701 In_Project : in out Project_Data;
702 In_Tree : Project_Tree_Ref)
706 when No_Language_Index =>
709 when First_Language_Indexes =>
710 In_Project.Naming.Impl_Suffixes (For_Language) := Suffix;
715 Supp_Index : Supp_Language_Index :=
716 In_Project.Naming.Supp_Suffixes;
719 while Supp_Index /= No_Supp_Language_Index loop
720 Supp := In_Tree.Supp_Suffixes.Table
723 if Supp.Index = For_Language then
724 In_Tree.Supp_Suffixes.Table
725 (Supp_Index).Suffix := Suffix;
729 Supp_Index := Supp.Next;
732 Supp := (Index => For_Language, Suffix => Suffix,
733 Next => In_Project.Naming.Supp_Suffixes);
734 Supp_Suffix_Table.Increment_Last
735 (In_Tree.Supp_Suffixes);
736 Supp_Index := Supp_Suffix_Table.Last
737 (In_Tree.Supp_Suffixes);
738 In_Tree.Supp_Suffixes.Table (Supp_Index) := Supp;
739 In_Project.Naming.Supp_Suffixes := Supp_Index;
748 function Slash return Name_Id is
753 --------------------------
754 -- Standard_Naming_Data --
755 --------------------------
757 function Standard_Naming_Data
758 (Tree : Project_Tree_Ref := No_Project_Tree) return Naming_Data
761 if Tree = No_Project_Tree then
762 Prj.Initialize (Tree => No_Project_Tree);
763 return Std_Naming_Data;
766 return Tree.Private_Part.Default_Naming;
768 end Standard_Naming_Data;
775 (Language : Language_Index;
776 In_Project : Project_Data;
777 In_Tree : Project_Tree_Ref) return Name_Id
781 when No_Language_Index =>
784 when First_Language_Indexes =>
785 return In_Project.Naming.Impl_Suffixes (Language);
790 Supp_Index : Supp_Language_Index :=
791 In_Project.Naming.Supp_Suffixes;
794 while Supp_Index /= No_Supp_Language_Index loop
795 Supp := In_Tree.Supp_Suffixes.Table (Supp_Index);
797 if Supp.Index = Language then
801 Supp_Index := Supp.Next;
813 function Value (Image : String) return Casing_Type is
815 for Casing in The_Casing_Images'Range loop
816 if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then
821 raise Constraint_Error;
825 -- Make sure that the standard project file extension is compatible
826 -- with canonical case file naming.
828 Canonical_Case_File_Name (Project_File_Extension);