| blob | a362fb8bd227347b55dc5ef8861e0e2b7c51cf69 |
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- P R J --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2001-2008, Free Software Foundation, Inc. --
10 -- --
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 3, 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
42 -- File suffix for object files
45 -- Initial size for extensible buffer used in Add_To_Buffer
58 -- Initialized in Prj.Initialize, then never modified
67 Initialized : Boolean := False;
69 Standard_Dot_Replacement : constant File_Name_Type :=
70 File_Name_Type
73 Std_Naming_Data : constant Naming_Data :=
74 (Dot_Replacement => Standard_Dot_Replacement,
75 Dot_Repl_Loc => No_Location,
76 Casing => All_Lower_Case,
77 Spec_Suffix => No_Array_Element,
78 Ada_Spec_Suffix_Loc => No_Location,
79 Body_Suffix => No_Array_Element,
80 Ada_Body_Suffix_Loc => No_Location,
81 Separate_Suffix => No_File,
82 Sep_Suffix_Loc => No_Location,
83 Specs => No_Array_Element,
84 Bodies => No_Array_Element,
85 Specification_Exceptions => No_Array_Element,
86 Implementation_Exceptions => No_Array_Element,
87 Impl_Suffixes => No_Impl_Suffixes,
88 Supp_Suffixes => No_Supp_Language_Index);
90 Project_Empty : constant Project_Data :=
91 (Qualifier => Unspecified,
92 Externally_Built => False,
93 Config => Default_Project_Config,
94 Languages => No_Name_List,
95 First_Referred_By => No_Project,
96 Name => No_Name,
97 Display_Name => No_Name,
98 Path_Name => No_Path,
99 Display_Path_Name => No_Path,
100 Virtual => False,
101 Location => No_Location,
102 Mains => Nil_String,
103 Directory => No_Path,
104 Display_Directory => No_Path,
105 Dir_Path => null,
106 Library => False,
107 Library_Dir => No_Path,
108 Display_Library_Dir => No_Path,
109 Library_Src_Dir => No_Path,
110 Display_Library_Src_Dir => No_Path,
111 Library_ALI_Dir => No_Path,
112 Display_Library_ALI_Dir => No_Path,
113 Library_Name => No_Name,
114 Library_Kind => Static,
115 Lib_Internal_Name => No_Name,
116 Standalone_Library => False,
117 Lib_Interface_ALIs => Nil_String,
118 Lib_Auto_Init => False,
119 Libgnarl_Needed => Unknown,
120 Symbol_Data => No_Symbols,
121 Ada_Sources => Nil_String,
122 Sources => Nil_String,
123 First_Source => No_Source,
124 Last_Source => No_Source,
125 Unit_Based_Language_Name => No_Name,
126 Unit_Based_Language_Index => No_Language_Index,
127 Imported_Directories_Switches => null,
128 Include_Path => null,
129 Include_Data_Set => False,
130 Include_Language => No_Language_Index,
131 Source_Dirs => Nil_String,
132 Known_Order_Of_Source_Dirs => True,
133 Object_Directory => No_Path,
134 Display_Object_Dir => No_Path,
135 Library_TS => Empty_Time_Stamp,
136 Exec_Directory => No_Path,
137 Display_Exec_Dir => No_Path,
138 Extends => No_Project,
139 Extended_By => No_Project,
140 Naming => Std_Naming_Data,
141 First_Language_Processing => No_Language_Index,
142 Decl => No_Declarations,
143 Imported_Projects => Empty_Project_List,
144 All_Imported_Projects => Empty_Project_List,
145 Ada_Include_Path => null,
146 Ada_Objects_Path => null,
147 Objects_Path => null,
148 Include_Path_File => No_Path,
149 Objects_Path_File_With_Libs => No_Path,
150 Objects_Path_File_Without_Libs => No_Path,
151 Config_File_Name => No_Path,
152 Config_File_Temp => False,
153 Linker_Name => No_File,
154 Linker_Path => No_Path,
155 Minimum_Linker_Options => No_Name_List,
156 Config_Checked => False,
157 Checked => False,
158 Seen => False,
159 Need_To_Build_Lib => False,
160 Depth => 0,
161 Unkept_Comments => False,
162 Langs => No_Languages,
163 Supp_Languages => No_Supp_Language_Index,
164 Ada_Sources_Present => True,
165 Other_Sources_Present => True,
166 First_Other_Source => No_Other_Source,
167 Last_Other_Source => No_Other_Source,
168 First_Lang_Processing =>
169 Default_First_Language_Processing_Data,
170 Supp_Language_Processing =>
171 No_Supp_Language_Index);
173 package Temp_Files is new Table.Table
174 (Table_Component_Type => Path_Name_Type,
175 Table_Index_Type => Integer,
176 Table_Low_Bound => 1,
177 Table_Initial => 20,
178 Table_Increment => 100,
179 Table_Name => "Makegpr.Temp_Files");
180 -- Table to store the path name of all the created temporary files, so that
181 -- they can be deleted at the end, or when the program is interrupted.
183 -----------------------
184 -- Add_Language_Name --
185 -----------------------
187 procedure Add_Language_Name (Name : Name_Id) is
188 begin
189 Last_Language_Index := Last_Language_Index + 1;
190 Language_Indexes.Set (Name, Last_Language_Index);
191 Language_Names.Increment_Last;
192 Language_Names.Table (Last_Language_Index) := Name;
193 end Add_Language_Name;
195 -------------------
196 -- Add_To_Buffer --
197 -------------------
199 procedure Add_To_Buffer
200 (S : String;
201 To : in out String_Access;
202 Last : in out Natural)
203 is
204 begin
205 if To = null then
206 To := new String (1 .. Initial_Buffer_Size);
207 Last := 0;
208 end if;
210 -- If Buffer is too small, double its size
212 while Last + S'Length > To'Last loop
213 declare
214 New_Buffer : constant String_Access :=
215 new String (1 .. 2 * Last);
217 begin
218 New_Buffer (1 .. Last) := To (1 .. Last);
219 Free (To);
220 To := New_Buffer;
221 end;
222 end loop;
224 To (Last + 1 .. Last + S'Length) := S;
225 Last := Last + S'Length;
226 end Add_To_Buffer;
228 -----------------------
229 -- Body_Suffix_Id_Of --
230 -----------------------
232 function Body_Suffix_Id_Of
233 (In_Tree : Project_Tree_Ref;
234 Language : String;
235 Naming : Naming_Data) return File_Name_Type
236 is
237 Language_Id : Name_Id;
239 begin
240 Name_Len := 0;
241 Add_Str_To_Name_Buffer (Language);
242 To_Lower (Name_Buffer (1 .. Name_Len));
243 Language_Id := Name_Find;
245 return
246 Body_Suffix_Id_Of
247 (In_Tree => In_Tree,
248 Language_Id => Language_Id,
249 Naming => Naming);
250 end Body_Suffix_Id_Of;
252 -----------------------
253 -- Body_Suffix_Id_Of --
254 -----------------------
256 function Body_Suffix_Id_Of
257 (In_Tree : Project_Tree_Ref;
258 Language_Id : Name_Id;
259 Naming : Naming_Data) return File_Name_Type
260 is
261 Element_Id : Array_Element_Id;
262 Element : Array_Element;
263 Suffix : File_Name_Type := No_File;
264 Lang : Language_Index;
266 begin
267 -- ??? This seems to be only for Ada_Only mode...
268 Element_Id := Naming.Body_Suffix;
269 while Element_Id /= No_Array_Element loop
270 Element := In_Tree.Array_Elements.Table (Element_Id);
272 if Element.Index = Language_Id then
273 return File_Name_Type (Element.Value.Value);
274 end if;
276 Element_Id := Element.Next;
277 end loop;
279 if Current_Mode = Multi_Language then
280 Lang := In_Tree.First_Language;
281 while Lang /= No_Language_Index loop
282 if In_Tree.Languages_Data.Table (Lang).Name = Language_Id then
283 Suffix :=
284 In_Tree.Languages_Data.Table
285 (Lang).Config.Naming_Data.Body_Suffix;
286 exit;
287 end if;
289 Lang := In_Tree.Languages_Data.Table (Lang).Next;
290 end loop;
291 end if;
293 return Suffix;
294 end Body_Suffix_Id_Of;
296 --------------------
297 -- Body_Suffix_Of --
298 --------------------
300 function Body_Suffix_Of
301 (In_Tree : Project_Tree_Ref;
302 Language : String;
303 Naming : Naming_Data) return String
304 is
305 Language_Id : Name_Id;
306 Element_Id : Array_Element_Id;
307 Element : Array_Element;
308 Suffix : File_Name_Type := No_File;
309 Lang : Language_Index;
311 begin
312 Name_Len := 0;
313 Add_Str_To_Name_Buffer (Language);
314 To_Lower (Name_Buffer (1 .. Name_Len));
315 Language_Id := Name_Find;
317 Element_Id := Naming.Body_Suffix;
318 while Element_Id /= No_Array_Element loop
319 Element := In_Tree.Array_Elements.Table (Element_Id);
321 if Element.Index = Language_Id then
322 return Get_Name_String (Element.Value.Value);
323 end if;
325 Element_Id := Element.Next;
326 end loop;
328 if Current_Mode = Multi_Language then
329 Lang := In_Tree.First_Language;
330 while Lang /= No_Language_Index loop
331 if In_Tree.Languages_Data.Table (Lang).Name = Language_Id then
332 Suffix :=
333 File_Name_Type
334 (In_Tree.Languages_Data.Table
335 (Lang).Config.Naming_Data.Body_Suffix);
336 exit;
337 end if;
339 Lang := In_Tree.Languages_Data.Table (Lang).Next;
340 end loop;
342 if Suffix /= No_File then
343 return Get_Name_String (Suffix);
344 end if;
345 end if;
347 return "";
348 end Body_Suffix_Of;
350 function Body_Suffix_Of
351 (Language : Language_Index;
352 In_Project : Project_Data;
353 In_Tree : Project_Tree_Ref) return String
354 is
355 Suffix_Id : constant File_Name_Type :=
356 Suffix_Of (Language, In_Project, In_Tree);
357 begin
358 if Suffix_Id /= No_File then
359 return Get_Name_String (Suffix_Id);
360 else
361 return "." & Get_Name_String (Language_Names.Table (Language));
362 end if;
363 end Body_Suffix_Of;
365 -----------------------------
366 -- Default_Ada_Body_Suffix --
367 -----------------------------
369 function Default_Ada_Body_Suffix return File_Name_Type is
370 begin
371 return Default_Ada_Body_Suffix_Id;
372 end Default_Ada_Body_Suffix;
374 -----------------------------
375 -- Default_Ada_Spec_Suffix --
376 -----------------------------
378 function Default_Ada_Spec_Suffix return File_Name_Type is
379 begin
380 return Default_Ada_Spec_Suffix_Id;
381 end Default_Ada_Spec_Suffix;
383 ---------------------------
384 -- Delete_All_Temp_Files --
385 ---------------------------
387 procedure Delete_All_Temp_Files is
388 Dont_Care : Boolean;
389 pragma Warnings (Off, Dont_Care);
390 begin
391 if not Debug.Debug_Flag_N then
392 for Index in 1 .. Temp_Files.Last loop
393 Delete_File
394 (Get_Name_String (Temp_Files.Table (Index)), Dont_Care);
395 end loop;
396 end if;
397 end Delete_All_Temp_Files;
399 ---------------------
400 -- Dependency_Name --
401 ---------------------
403 function Dependency_Name
404 (Source_File_Name : File_Name_Type;
405 Dependency : Dependency_File_Kind) return File_Name_Type
406 is
407 begin
408 case Dependency is
409 when None =>
410 return No_File;
412 when Makefile =>
413 return
414 File_Name_Type
415 (Extend_Name
416 (Source_File_Name, Makefile_Dependency_Suffix));
418 when ALI_File =>
419 return
420 File_Name_Type
421 (Extend_Name
422 (Source_File_Name, ALI_Dependency_Suffix));
423 end case;
424 end Dependency_Name;
426 ---------------------------
427 -- Display_Language_Name --
428 ---------------------------
430 procedure Display_Language_Name
431 (In_Tree : Project_Tree_Ref;
432 Language : Language_Index)
433 is
434 begin
435 Get_Name_String (In_Tree.Languages_Data.Table (Language).Display_Name);
436 Write_Str (Name_Buffer (1 .. Name_Len));
437 end Display_Language_Name;
439 ---------------------------
440 -- Display_Language_Name --
441 ---------------------------
443 procedure Display_Language_Name (Language : Language_Index) is
444 begin
445 Get_Name_String (Language_Names.Table (Language));
446 To_Upper (Name_Buffer (1 .. 1));
447 Write_Str (Name_Buffer (1 .. Name_Len));
448 end Display_Language_Name;
450 ----------------
451 -- Empty_File --
452 ----------------
454 function Empty_File return File_Name_Type is
455 begin
456 return File_Name_Type (The_Empty_String);
457 end Empty_File;
459 -------------------
460 -- Empty_Project --
461 -------------------
463 function Empty_Project (Tree : Project_Tree_Ref) return Project_Data is
464 Value : Project_Data;
466 begin
467 Prj.Initialize (Tree => No_Project_Tree);
468 Value := Project_Empty;
469 Value.Naming := Tree.Private_Part.Default_Naming;
471 return Value;
472 end Empty_Project;
474 ------------------
475 -- Empty_String --
476 ------------------
478 function Empty_String return Name_Id is
479 begin
480 return The_Empty_String;
481 end Empty_String;
483 ------------
484 -- Expect --
485 ------------
487 procedure Expect (The_Token : Token_Type; Token_Image : String) is
488 begin
489 if Token /= The_Token then
490 Error_Msg (Token_Image & " expected", Token_Ptr);
491 end if;
492 end Expect;
494 -----------------
495 -- Extend_Name --
496 -----------------
498 function Extend_Name
499 (File : File_Name_Type;
500 With_Suffix : String) return File_Name_Type
501 is
502 Last : Positive;
504 begin
505 Get_Name_String (File);
506 Last := Name_Len + 1;
509 Name_Len := Name_Len - 1;
510 end loop;
512 if Name_Len <= 1 then
513 Name_Len := Last;
514 end if;
516 for J in With_Suffix'Range loop
517 Name_Buffer (Name_Len) := With_Suffix (J);
518 Name_Len := Name_Len + 1;
519 end loop;
521 Name_Len := Name_Len - 1;
522 return Name_Find;
524 end Extend_Name;
526 --------------------------------
527 -- For_Every_Project_Imported --
528 --------------------------------
530 procedure For_Every_Project_Imported
531 (By : Project_Id;
532 In_Tree : Project_Tree_Ref;
533 With_State : in out State)
534 is
536 procedure Recursive_Check (Project : Project_Id);
537 -- Check if a project has already been seen. If not seen, mark it as
538 -- Seen, Call Action, and check all its imported projects.
540 ---------------------
541 -- Recursive_Check --
542 ---------------------
544 procedure Recursive_Check (Project : Project_Id) is
545 List : Project_List;
546 begin
547 if not In_Tree.Projects.Table (Project).Seen then
548 In_Tree.Projects.Table (Project).Seen := True;
549 Action (Project, With_State);
551 List := In_Tree.Projects.Table (Project).Imported_Projects;
552 while List /= Empty_Project_List loop
553 Recursive_Check (In_Tree.Project_Lists.Table (List).Project);
554 List := In_Tree.Project_Lists.Table (List).Next;
555 end loop;
556 end if;
557 end Recursive_Check;
559 -- Start of processing for For_Every_Project_Imported
561 begin
562 for Project in Project_Table.First ..
563 Project_Table.Last (In_Tree.Projects)
564 loop
565 In_Tree.Projects.Table (Project).Seen := False;
566 end loop;
568 Recursive_Check (Project => By);
569 end For_Every_Project_Imported;
571 --------------
572 -- Get_Mode --
573 --------------
575 function Get_Mode return Mode is
576 begin
577 return Current_Mode;
578 end Get_Mode;
580 ----------
581 -- Hash --
582 ----------
584 function Hash is new System.HTable.Hash (Header_Num => Header_Num);
585 -- Used in implementation of other functions Hash below
587 function Hash (Name : File_Name_Type) return Header_Num is
588 begin
589 return Hash (Get_Name_String (Name));
590 end Hash;
592 function Hash (Name : Name_Id) return Header_Num is
593 begin
594 return Hash (Get_Name_String (Name));
595 end Hash;
597 function Hash (Name : Path_Name_Type) return Header_Num is
598 begin
599 return Hash (Get_Name_String (Name));
600 end Hash;
602 -----------
603 -- Image --
604 -----------
606 function Image (Casing : Casing_Type) return String is
607 begin
608 return The_Casing_Images (Casing).all;
609 end Image;
611 ----------------------
612 -- In_Configuration --
613 ----------------------
615 function In_Configuration return Boolean is
616 begin
617 return Configuration_Mode;
618 end In_Configuration;
620 ----------------
621 -- Initialize --
622 ----------------
624 procedure Initialize (Tree : Project_Tree_Ref) is
625 begin
626 if not Initialized then
627 Initialized := True;
628 Uintp.Initialize;
629 Name_Len := 0;
630 The_Empty_String := Name_Find;
631 Empty_Name := The_Empty_String;
632 Empty_File_Name := File_Name_Type (The_Empty_String);
633 Name_Len := 4;
634 Name_Buffer (1 .. 4) := ".ads";
635 Default_Ada_Spec_Suffix_Id := Name_Find;
636 Name_Len := 4;
637 Name_Buffer (1 .. 4) := ".adb";
638 Default_Ada_Body_Suffix_Id := Name_Find;
639 Name_Len := 1;
641 Slash_Id := Name_Find;
642 Name_Len := 3;
643 Name_Buffer (1 .. 3) := "c++";
644 Name_C_Plus_Plus := Name_Find;
646 Prj.Env.Initialize;
647 Prj.Attr.Initialize;
648 Set_Name_Table_Byte (Name_Project, Token_Type'Pos (Tok_Project));
649 Set_Name_Table_Byte (Name_Extends, Token_Type'Pos (Tok_Extends));
650 Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External));
652 Language_Indexes.Reset;
653 Last_Language_Index := No_Language_Index;
654 Language_Names.Init;
655 Add_Language_Name (Name_Ada);
656 Add_Language_Name (Name_C);
657 Add_Language_Name (Name_C_Plus_Plus);
658 end if;
660 if Tree /= No_Project_Tree then
661 Reset (Tree);
662 end if;
663 end Initialize;
665 -------------------
666 -- Is_A_Language --
667 -------------------
669 function Is_A_Language
670 (Tree : Project_Tree_Ref;
671 Data : Project_Data;
672 Language_Name : Name_Id) return Boolean
673 is
674 begin
675 if Get_Mode = Ada_Only then
676 declare
677 List : Name_List_Index := Data.Languages;
678 begin
679 while List /= No_Name_List loop
680 if Tree.Name_Lists.Table (List).Name = Language_Name then
681 return True;
682 else
683 List := Tree.Name_Lists.Table (List).Next;
684 end if;
685 end loop;
686 end;
688 else
689 declare
690 Lang_Ind : Language_Index := Data.First_Language_Processing;
691 Lang_Data : Language_Data;
693 begin
694 while Lang_Ind /= No_Language_Index loop
695 Lang_Data := Tree.Languages_Data.Table (Lang_Ind);
697 if Lang_Data.Name = Language_Name then
698 return True;
699 end if;
701 Lang_Ind := Lang_Data.Next;
702 end loop;
703 end;
704 end if;
706 return False;
707 end Is_A_Language;
709 ------------------
710 -- Is_Extending --
711 ------------------
713 function Is_Extending
714 (Extending : Project_Id;
715 Extended : Project_Id;
716 In_Tree : Project_Tree_Ref) return Boolean
717 is
718 Proj : Project_Id;
720 begin
721 Proj := Extending;
722 while Proj /= No_Project loop
723 if Proj = Extended then
724 return True;
725 end if;
727 Proj := In_Tree.Projects.Table (Proj).Extends;
728 end loop;
730 return False;
731 end Is_Extending;
733 ----------------
734 -- Is_Present --
735 ----------------
737 function Is_Present
738 (Language : Language_Index;
739 In_Project : Project_Data;
740 In_Tree : Project_Tree_Ref) return Boolean
741 is
742 begin
743 case Language is
744 when No_Language_Index =>
745 return False;
747 when First_Language_Indexes =>
748 return In_Project.Langs (Language);
750 when others =>
751 declare
752 Supp : Supp_Language;
753 Supp_Index : Supp_Language_Index;
755 begin
756 Supp_Index := In_Project.Supp_Languages;
757 while Supp_Index /= No_Supp_Language_Index loop
758 Supp := In_Tree.Present_Languages.Table (Supp_Index);
760 if Supp.Index = Language then
761 return Supp.Present;
762 end if;
764 Supp_Index := Supp.Next;
765 end loop;
767 return False;
768 end;
769 end case;
770 end Is_Present;
772 ---------------------------------
773 -- Language_Processing_Data_Of --
774 ---------------------------------
776 function Language_Processing_Data_Of
777 (Language : Language_Index;
778 In_Project : Project_Data;
779 In_Tree : Project_Tree_Ref) return Language_Processing_Data
780 is
781 begin
782 case Language is
783 when No_Language_Index =>
784 return Default_Language_Processing_Data;
786 when First_Language_Indexes =>
787 return In_Project.First_Lang_Processing (Language);
789 when others =>
790 declare
791 Supp : Supp_Language_Data;
792 Supp_Index : Supp_Language_Index;
794 begin
795 Supp_Index := In_Project.Supp_Language_Processing;
796 while Supp_Index /= No_Supp_Language_Index loop
797 Supp := In_Tree.Supp_Languages.Table (Supp_Index);
799 if Supp.Index = Language then
800 return Supp.Data;
801 end if;
803 Supp_Index := Supp.Next;
804 end loop;
806 return Default_Language_Processing_Data;
807 end;
808 end case;
809 end Language_Processing_Data_Of;
811 -----------------------
812 -- Objects_Exist_For --
813 -----------------------
815 function Objects_Exist_For
816 (Language : String;
817 In_Tree : Project_Tree_Ref) return Boolean
818 is
819 Language_Id : Name_Id;
820 Lang : Language_Index;
822 begin
823 if Current_Mode = Multi_Language then
824 Name_Len := 0;
825 Add_Str_To_Name_Buffer (Language);
826 To_Lower (Name_Buffer (1 .. Name_Len));
827 Language_Id := Name_Find;
829 Lang := In_Tree.First_Language;
830 while Lang /= No_Language_Index loop
831 if In_Tree.Languages_Data.Table (Lang).Name = Language_Id then
832 return
833 In_Tree.Languages_Data.Table
834 (Lang).Config.Objects_Generated;
835 end if;
837 Lang := In_Tree.Languages_Data.Table (Lang).Next;
838 end loop;
839 end if;
841 return True;
842 end Objects_Exist_For;
844 -----------------
845 -- Object_Name --
846 -----------------
848 function Object_Name
849 (Source_File_Name : File_Name_Type)
850 return File_Name_Type
851 is
852 begin
853 return Extend_Name (Source_File_Name, Object_Suffix);
854 end Object_Name;
856 ----------------------
857 -- Record_Temp_File --
858 ----------------------
860 procedure Record_Temp_File (Path : Path_Name_Type) is
861 begin
862 Temp_Files.Increment_Last;
863 Temp_Files.Table (Temp_Files.Last) := Path;
864 end Record_Temp_File;
866 ------------------------------------
867 -- Register_Default_Naming_Scheme --
868 ------------------------------------
870 procedure Register_Default_Naming_Scheme
871 (Language : Name_Id;
872 Default_Spec_Suffix : File_Name_Type;
873 Default_Body_Suffix : File_Name_Type;
874 In_Tree : Project_Tree_Ref)
875 is
876 Lang : Name_Id;
877 Suffix : Array_Element_Id;
878 Found : Boolean := False;
879 Element : Array_Element;
881 begin
882 -- Get the language name in small letters
884 Get_Name_String (Language);
885 Name_Buffer (1 .. Name_Len) := To_Lower (Name_Buffer (1 .. Name_Len));
886 Lang := Name_Find;
888 -- Look for an element of the spec suffix array indexed by the language
889 -- name. If one is found, put the default value.
891 Suffix := In_Tree.Private_Part.Default_Naming.Spec_Suffix;
892 Found := False;
893 while Suffix /= No_Array_Element and then not Found loop
894 Element := In_Tree.Array_Elements.Table (Suffix);
896 if Element.Index = Lang then
897 Found := True;
898 Element.Value.Value := Name_Id (Default_Spec_Suffix);
899 In_Tree.Array_Elements.Table (Suffix) := Element;
901 else
902 Suffix := Element.Next;
903 end if;
904 end loop;
906 -- If none can be found, create a new one
908 if not Found then
909 Element :=
910 (Index => Lang,
911 Src_Index => 0,
912 Index_Case_Sensitive => False,
913 Value => (Project => No_Project,
914 Kind => Single,
915 Location => No_Location,
916 Default => False,
917 Value => Name_Id (Default_Spec_Suffix),
918 Index => 0),
919 Next => In_Tree.Private_Part.Default_Naming.Spec_Suffix);
920 Array_Element_Table.Increment_Last (In_Tree.Array_Elements);
921 In_Tree.Array_Elements.Table
922 (Array_Element_Table.Last (In_Tree.Array_Elements)) :=
923 Element;
924 In_Tree.Private_Part.Default_Naming.Spec_Suffix :=
925 Array_Element_Table.Last (In_Tree.Array_Elements);
926 end if;
928 -- Look for an element of the body suffix array indexed by the language
929 -- name. If one is found, put the default value.
931 Suffix := In_Tree.Private_Part.Default_Naming.Body_Suffix;
932 Found := False;
933 while Suffix /= No_Array_Element and then not Found loop
934 Element := In_Tree.Array_Elements.Table (Suffix);
936 if Element.Index = Lang then
937 Found := True;
938 Element.Value.Value := Name_Id (Default_Body_Suffix);
939 In_Tree.Array_Elements.Table (Suffix) := Element;
941 else
942 Suffix := Element.Next;
943 end if;
944 end loop;
946 -- If none can be found, create a new one
948 if not Found then
949 Element :=
950 (Index => Lang,
951 Src_Index => 0,
952 Index_Case_Sensitive => False,
953 Value => (Project => No_Project,
954 Kind => Single,
955 Location => No_Location,
956 Default => False,
957 Value => Name_Id (Default_Body_Suffix),
958 Index => 0),
959 Next => In_Tree.Private_Part.Default_Naming.Body_Suffix);
960 Array_Element_Table.Increment_Last
961 (In_Tree.Array_Elements);
962 In_Tree.Array_Elements.Table
963 (Array_Element_Table.Last (In_Tree.Array_Elements))
964 := Element;
965 In_Tree.Private_Part.Default_Naming.Body_Suffix :=
966 Array_Element_Table.Last (In_Tree.Array_Elements);
967 end if;
968 end Register_Default_Naming_Scheme;
970 -----------
971 -- Reset --
972 -----------
974 procedure Reset (Tree : Project_Tree_Ref) is
976 -- Def_Lang : constant Name_Node :=
977 -- (Name => Name_Ada,
978 -- Next => No_Name_List);
979 -- Why is the above commented out ???
981 begin
982 Prj.Env.Initialize;
984 -- gprmake tables
986 Present_Language_Table.Init (Tree.Present_Languages);
987 Supp_Suffix_Table.Init (Tree.Supp_Suffixes);
988 Supp_Language_Table.Init (Tree.Supp_Languages);
989 Other_Source_Table.Init (Tree.Other_Sources);
991 -- Visible tables
993 Language_Data_Table.Init (Tree.Languages_Data);
994 Name_List_Table.Init (Tree.Name_Lists);
995 String_Element_Table.Init (Tree.String_Elements);
996 Variable_Element_Table.Init (Tree.Variable_Elements);
997 Array_Element_Table.Init (Tree.Array_Elements);
998 Array_Table.Init (Tree.Arrays);
999 Package_Table.Init (Tree.Packages);
1000 Project_List_Table.Init (Tree.Project_Lists);
1001 Project_Table.Init (Tree.Projects);
1002 Source_Data_Table.Init (Tree.Sources);
1003 Alternate_Language_Table.Init (Tree.Alt_Langs);
1004 Unit_Table.Init (Tree.Units);
1005 Units_Htable.Reset (Tree.Units_HT);
1006 Files_Htable.Reset (Tree.Files_HT);
1007 Source_Paths_Htable.Reset (Tree.Source_Paths_HT);
1009 -- Private part table
1011 Naming_Table.Init (Tree.Private_Part.Namings);
1012 Naming_Table.Increment_Last (Tree.Private_Part.Namings);
1013 Tree.Private_Part.Namings.Table
1014 (Naming_Table.Last (Tree.Private_Part.Namings)) := Std_Naming_Data;
1015 Path_File_Table.Init (Tree.Private_Part.Path_Files);
1016 Source_Path_Table.Init (Tree.Private_Part.Source_Paths);
1017 Object_Path_Table.Init (Tree.Private_Part.Object_Paths);
1018 Tree.Private_Part.Default_Naming := Std_Naming_Data;
1020 if Current_Mode = Ada_Only then
1021 Register_Default_Naming_Scheme
1022 (Language => Name_Ada,
1023 Default_Spec_Suffix => Default_Ada_Spec_Suffix,
1024 Default_Body_Suffix => Default_Ada_Body_Suffix,
1025 In_Tree => Tree);
1026 Tree.Private_Part.Default_Naming.Separate_Suffix :=
1027 Default_Ada_Body_Suffix;
1028 end if;
1029 end Reset;
1031 ------------------------
1032 -- Same_Naming_Scheme --
1033 ------------------------
1035 function Same_Naming_Scheme
1036 (Left, Right : Naming_Data) return Boolean
1037 is
1038 begin
1039 return Left.Dot_Replacement = Right.Dot_Replacement
1040 and then Left.Casing = Right.Casing
1041 and then Left.Separate_Suffix = Right.Separate_Suffix;
1042 end Same_Naming_Scheme;
1044 ---------
1045 -- Set --
1046 ---------
1048 procedure Set
1049 (Language : Language_Index;
1050 Present : Boolean;
1051 In_Project : in out Project_Data;
1052 In_Tree : Project_Tree_Ref)
1053 is
1054 begin
1055 case Language is
1056 when No_Language_Index =>
1057 null;
1059 when First_Language_Indexes =>
1060 In_Project.Langs (Language) := Present;
1062 when others =>
1063 declare
1064 Supp : Supp_Language;
1065 Supp_Index : Supp_Language_Index;
1067 begin
1068 Supp_Index := In_Project.Supp_Languages;
1069 while Supp_Index /= No_Supp_Language_Index loop
1070 Supp := In_Tree.Present_Languages.Table (Supp_Index);
1072 if Supp.Index = Language then
1073 In_Tree.Present_Languages.Table (Supp_Index).Present :=
1074 Present;
1075 return;
1076 end if;
1078 Supp_Index := Supp.Next;
1079 end loop;
1081 Supp := (Index => Language, Present => Present,
1082 Next => In_Project.Supp_Languages);
1083 Present_Language_Table.Increment_Last
1084 (In_Tree.Present_Languages);
1085 Supp_Index :=
1086 Present_Language_Table.Last (In_Tree.Present_Languages);
1087 In_Tree.Present_Languages.Table (Supp_Index) :=
1088 Supp;
1089 In_Project.Supp_Languages := Supp_Index;
1090 end;
1091 end case;
1092 end Set;
1094 procedure Set
1095 (Language_Processing : Language_Processing_Data;
1096 For_Language : Language_Index;
1097 In_Project : in out Project_Data;
1098 In_Tree : Project_Tree_Ref)
1099 is
1100 begin
1101 case For_Language is
1102 when No_Language_Index =>
1103 null;
1105 when First_Language_Indexes =>
1106 In_Project.First_Lang_Processing (For_Language) :=
1107 Language_Processing;
1109 when others =>
1110 declare
1111 Supp : Supp_Language_Data;
1112 Supp_Index : Supp_Language_Index;
1114 begin
1115 Supp_Index := In_Project.Supp_Language_Processing;
1116 while Supp_Index /= No_Supp_Language_Index loop
1117 Supp := In_Tree.Supp_Languages.Table (Supp_Index);
1119 if Supp.Index = For_Language then
1120 In_Tree.Supp_Languages.Table
1121 (Supp_Index).Data := Language_Processing;
1122 return;
1123 end if;
1125 Supp_Index := Supp.Next;
1126 end loop;
1128 Supp := (Index => For_Language, Data => Language_Processing,
1129 Next => In_Project.Supp_Language_Processing);
1130 Supp_Language_Table.Increment_Last
1131 (In_Tree.Supp_Languages);
1132 Supp_Index := Supp_Language_Table.Last
1133 (In_Tree.Supp_Languages);
1134 In_Tree.Supp_Languages.Table (Supp_Index) := Supp;
1135 In_Project.Supp_Language_Processing := Supp_Index;
1136 end;
1137 end case;
1138 end Set;
1140 procedure Set
1141 (Suffix : File_Name_Type;
1142 For_Language : Language_Index;
1143 In_Project : in out Project_Data;
1144 In_Tree : Project_Tree_Ref)
1145 is
1146 begin
1147 case For_Language is
1148 when No_Language_Index =>
1149 null;
1151 when First_Language_Indexes =>
1152 In_Project.Naming.Impl_Suffixes (For_Language) := Suffix;
1154 when others =>
1155 declare
1156 Supp : Supp_Suffix;
1157 Supp_Index : Supp_Language_Index;
1159 begin
1160 Supp_Index := In_Project.Naming.Supp_Suffixes;
1161 while Supp_Index /= No_Supp_Language_Index loop
1162 Supp := In_Tree.Supp_Suffixes.Table (Supp_Index);
1164 if Supp.Index = For_Language then
1165 In_Tree.Supp_Suffixes.Table (Supp_Index).Suffix := Suffix;
1166 return;
1167 end if;
1169 Supp_Index := Supp.Next;
1170 end loop;
1172 Supp := (Index => For_Language, Suffix => Suffix,
1173 Next => In_Project.Naming.Supp_Suffixes);
1174 Supp_Suffix_Table.Increment_Last (In_Tree.Supp_Suffixes);
1175 Supp_Index := Supp_Suffix_Table.Last (In_Tree.Supp_Suffixes);
1176 In_Tree.Supp_Suffixes.Table (Supp_Index) := Supp;
1177 In_Project.Naming.Supp_Suffixes := Supp_Index;
1178 end;
1179 end case;
1180 end Set;
1182 ---------------------
1183 -- Set_Body_Suffix --
1184 ---------------------
1186 procedure Set_Body_Suffix
1187 (In_Tree : Project_Tree_Ref;
1188 Language : String;
1189 Naming : in out Naming_Data;
1190 Suffix : File_Name_Type)
1191 is
1192 Language_Id : Name_Id;
1193 Element : Array_Element;
1195 begin
1196 Name_Len := 0;
1197 Add_Str_To_Name_Buffer (Language);
1198 To_Lower (Name_Buffer (1 .. Name_Len));
1199 Language_Id := Name_Find;
1201 Element :=
1202 (Index => Language_Id,
1203 Src_Index => 0,
1204 Index_Case_Sensitive => False,
1205 Value =>
1206 (Kind => Single,
1207 Project => No_Project,
1208 Location => No_Location,
1209 Default => False,
1210 Value => Name_Id (Suffix),
1211 Index => 0),
1212 Next => Naming.Body_Suffix);
1214 Array_Element_Table.Increment_Last (In_Tree.Array_Elements);
1215 Naming.Body_Suffix :=
1216 Array_Element_Table.Last (In_Tree.Array_Elements);
1217 In_Tree.Array_Elements.Table (Naming.Body_Suffix) := Element;
1218 end Set_Body_Suffix;
1220 --------------------------
1221 -- Set_In_Configuration --
1222 --------------------------
1224 procedure Set_In_Configuration (Value : Boolean) is
1225 begin
1226 Configuration_Mode := Value;
1227 end Set_In_Configuration;
1229 --------------
1230 -- Set_Mode --
1231 --------------
1233 procedure Set_Mode (New_Mode : Mode) is
1234 begin
1235 Current_Mode := New_Mode;
1236 case New_Mode is
1237 when Ada_Only =>
1238 Default_Language_Is_Ada := True;
1239 Must_Check_Configuration := False;
1240 when Multi_Language =>
1241 Default_Language_Is_Ada := False;
1242 Must_Check_Configuration := True;
1243 end case;
1244 end Set_Mode;
1246 ---------------------
1247 -- Set_Spec_Suffix --
1248 ---------------------
1250 procedure Set_Spec_Suffix
1251 (In_Tree : Project_Tree_Ref;
1252 Language : String;
1253 Naming : in out Naming_Data;
1254 Suffix : File_Name_Type)
1255 is
1256 Language_Id : Name_Id;
1257 Element : Array_Element;
1259 begin
1260 Name_Len := 0;
1261 Add_Str_To_Name_Buffer (Language);
1262 To_Lower (Name_Buffer (1 .. Name_Len));
1263 Language_Id := Name_Find;
1265 Element :=
1266 (Index => Language_Id,
1267 Src_Index => 0,
1268 Index_Case_Sensitive => False,
1269 Value =>
1270 (Kind => Single,
1271 Project => No_Project,
1272 Location => No_Location,
1273 Default => False,
1274 Value => Name_Id (Suffix),
1275 Index => 0),
1276 Next => Naming.Spec_Suffix);
1278 Array_Element_Table.Increment_Last (In_Tree.Array_Elements);
1279 Naming.Spec_Suffix :=
1280 Array_Element_Table.Last (In_Tree.Array_Elements);
1281 In_Tree.Array_Elements.Table (Naming.Spec_Suffix) := Element;
1282 end Set_Spec_Suffix;
1284 -----------
1285 -- Slash --
1286 -----------
1288 function Slash return Path_Name_Type is
1289 begin
1290 return Slash_Id;
1291 end Slash;
1293 -----------------------
1294 -- Spec_Suffix_Id_Of --
1295 -----------------------
1297 function Spec_Suffix_Id_Of
1298 (In_Tree : Project_Tree_Ref;
1299 Language : String;
1300 Naming : Naming_Data) return File_Name_Type
1301 is
1302 Language_Id : Name_Id;
1304 begin
1305 Name_Len := 0;
1306 Add_Str_To_Name_Buffer (Language);
1307 To_Lower (Name_Buffer (1 .. Name_Len));
1308 Language_Id := Name_Find;
1310 return
1311 Spec_Suffix_Id_Of
1312 (In_Tree => In_Tree,
1313 Language_Id => Language_Id,
1314 Naming => Naming);
1315 end Spec_Suffix_Id_Of;
1317 -----------------------
1318 -- Spec_Suffix_Id_Of --
1319 -----------------------
1321 function Spec_Suffix_Id_Of
1322 (In_Tree : Project_Tree_Ref;
1323 Language_Id : Name_Id;
1324 Naming : Naming_Data) return File_Name_Type
1325 is
1326 Element_Id : Array_Element_Id;
1327 Element : Array_Element;
1328 Suffix : File_Name_Type := No_File;
1329 Lang : Language_Index;
1331 begin
1332 Element_Id := Naming.Spec_Suffix;
1333 while Element_Id /= No_Array_Element loop
1334 Element := In_Tree.Array_Elements.Table (Element_Id);
1336 if Element.Index = Language_Id then
1337 return File_Name_Type (Element.Value.Value);
1338 end if;
1340 Element_Id := Element.Next;
1341 end loop;
1343 if Current_Mode = Multi_Language then
1344 Lang := In_Tree.First_Language;
1345 while Lang /= No_Language_Index loop
1346 if In_Tree.Languages_Data.Table (Lang).Name = Language_Id then
1347 Suffix :=
1348 In_Tree.Languages_Data.Table
1349 (Lang).Config.Naming_Data.Spec_Suffix;
1350 exit;
1351 end if;
1353 Lang := In_Tree.Languages_Data.Table (Lang).Next;
1354 end loop;
1355 end if;
1357 return Suffix;
1358 end Spec_Suffix_Id_Of;
1360 --------------------
1361 -- Spec_Suffix_Of --
1362 --------------------
1364 function Spec_Suffix_Of
1365 (In_Tree : Project_Tree_Ref;
1366 Language : String;
1367 Naming : Naming_Data) return String
1368 is
1369 Language_Id : Name_Id;
1370 Element_Id : Array_Element_Id;
1371 Element : Array_Element;
1372 Suffix : File_Name_Type := No_File;
1373 Lang : Language_Index;
1375 begin
1376 Name_Len := 0;
1377 Add_Str_To_Name_Buffer (Language);
1378 To_Lower (Name_Buffer (1 .. Name_Len));
1379 Language_Id := Name_Find;
1381 Element_Id := Naming.Spec_Suffix;
1382 while Element_Id /= No_Array_Element loop
1383 Element := In_Tree.Array_Elements.Table (Element_Id);
1385 if Element.Index = Language_Id then
1386 return Get_Name_String (Element.Value.Value);
1387 end if;
1389 Element_Id := Element.Next;
1390 end loop;
1392 if Current_Mode = Multi_Language then
1393 Lang := In_Tree.First_Language;
1394 while Lang /= No_Language_Index loop
1395 if In_Tree.Languages_Data.Table (Lang).Name = Language_Id then
1396 Suffix :=
1397 File_Name_Type
1398 (In_Tree.Languages_Data.Table
1399 (Lang).Config.Naming_Data.Spec_Suffix);
1400 exit;
1401 end if;
1403 Lang := In_Tree.Languages_Data.Table (Lang).Next;
1404 end loop;
1406 if Suffix /= No_File then
1407 return Get_Name_String (Suffix);
1408 end if;
1409 end if;
1411 return "";
1412 end Spec_Suffix_Of;
1414 --------------------------
1415 -- Standard_Naming_Data --
1416 --------------------------
1418 function Standard_Naming_Data
1419 (Tree : Project_Tree_Ref := No_Project_Tree) return Naming_Data
1420 is
1421 begin
1422 if Tree = No_Project_Tree then
1423 Prj.Initialize (Tree => No_Project_Tree);
1424 return Std_Naming_Data;
1425 else
1426 return Tree.Private_Part.Default_Naming;
1427 end if;
1428 end Standard_Naming_Data;
1430 ---------------
1431 -- Suffix_Of --
1432 ---------------
1434 function Suffix_Of
1435 (Language : Language_Index;
1436 In_Project : Project_Data;
1437 In_Tree : Project_Tree_Ref) return File_Name_Type
1438 is
1439 begin
1440 case Language is
1441 when No_Language_Index =>
1442 return No_File;
1444 when First_Language_Indexes =>
1445 return In_Project.Naming.Impl_Suffixes (Language);
1447 when others =>
1448 declare
1449 Supp : Supp_Suffix;
1450 Supp_Index : Supp_Language_Index;
1452 begin
1453 Supp_Index := In_Project.Naming.Supp_Suffixes;
1454 while Supp_Index /= No_Supp_Language_Index loop
1455 Supp := In_Tree.Supp_Suffixes.Table (Supp_Index);
1457 if Supp.Index = Language then
1458 return Supp.Suffix;
1459 end if;
1461 Supp_Index := Supp.Next;
1462 end loop;
1464 return No_File;
1465 end;
1466 end case;
1467 end Suffix_Of;
1469 -------------------
1470 -- Switches_Name --
1471 -------------------
1473 function Switches_Name
1474 (Source_File_Name : File_Name_Type) return File_Name_Type
1475 is
1476 begin
1477 return Extend_Name (Source_File_Name, Switches_Dependency_Suffix);
1478 end Switches_Name;
1480 ---------------------------
1481 -- There_Are_Ada_Sources --
1482 ---------------------------
1484 function There_Are_Ada_Sources
1485 (In_Tree : Project_Tree_Ref;
1486 Project : Project_Id) return Boolean
1487 is
1488 Prj : Project_Id;
1490 begin
1491 Prj := Project;
1492 while Prj /= No_Project loop
1493 if In_Tree.Projects.Table (Prj).Ada_Sources /= Nil_String then
1494 return True;
1495 end if;
1497 Prj := In_Tree.Projects.Table (Prj).Extends;
1498 end loop;
1500 return False;
1501 end There_Are_Ada_Sources;
1503 -----------
1504 -- Value --
1505 -----------
1507 function Value (Image : String) return Casing_Type is
1508 begin
1509 for Casing in The_Casing_Images'Range loop
1510 if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then
1511 return Casing;
1512 end if;
1513 end loop;
1515 raise Constraint_Error;
1516 end Value;
1518 begin
1519 -- Make sure that the standard config and user project file extensions are
1520 -- compatible with canonical case file naming.
1522 Canonical_Case_File_Name (Config_Project_File_Extension);
1523 Canonical_Case_File_Name (Project_File_Extension);
1524 end Prj;