| blob | d838b1144424036362b3785d605a0f7bcdc35d4f |
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 => No_Path_Information,
99 Virtual => False,
100 Location => No_Location,
101 Mains => Nil_String,
102 Directory => No_Path_Information,
103 Dir_Path => null,
104 Library => False,
105 Library_Dir => No_Path_Information,
106 Library_Src_Dir => No_Path_Information,
107 Library_ALI_Dir => No_Path_Information,
108 Library_Name => No_Name,
109 Library_Kind => Static,
110 Lib_Internal_Name => No_Name,
111 Standalone_Library => False,
112 Lib_Interface_ALIs => Nil_String,
113 Lib_Auto_Init => False,
114 Libgnarl_Needed => Unknown,
115 Symbol_Data => No_Symbols,
116 Ada_Sources => Nil_String,
117 Sources => Nil_String,
118 First_Source => No_Source,
119 Last_Source => No_Source,
120 Interfaces_Defined => False,
121 Unit_Based_Language_Name => No_Name,
122 Unit_Based_Language_Index => No_Language_Index,
123 Imported_Directories_Switches => null,
124 Include_Path => null,
125 Include_Data_Set => False,
126 Include_Language => No_Language_Index,
127 Source_Dirs => Nil_String,
128 Known_Order_Of_Source_Dirs => True,
129 Object_Directory => No_Path_Information,
130 Library_TS => Empty_Time_Stamp,
131 Exec_Directory => No_Path_Information,
132 Extends => No_Project,
133 Extended_By => No_Project,
134 Naming => Std_Naming_Data,
135 First_Language_Processing => No_Language_Index,
136 Decl => No_Declarations,
137 Imported_Projects => Empty_Project_List,
138 All_Imported_Projects => Empty_Project_List,
139 Ada_Include_Path => null,
140 Ada_Objects_Path => null,
141 Objects_Path => null,
142 Include_Path_File => No_Path,
143 Objects_Path_File_With_Libs => No_Path,
144 Objects_Path_File_Without_Libs => No_Path,
145 Config_File_Name => No_Path,
146 Config_File_Temp => False,
147 Linker_Name => No_File,
148 Linker_Path => No_Path,
149 Minimum_Linker_Options => No_Name_List,
150 Config_Checked => False,
151 Checked => False,
152 Seen => False,
153 Need_To_Build_Lib => False,
154 Depth => 0,
155 Unkept_Comments => False,
156 Langs => No_Languages,
157 Supp_Languages => No_Supp_Language_Index,
158 Ada_Sources_Present => True,
159 Other_Sources_Present => True,
160 First_Other_Source => No_Other_Source,
161 Last_Other_Source => No_Other_Source,
162 First_Lang_Processing =>
163 Default_First_Language_Processing_Data,
164 Supp_Language_Processing =>
165 No_Supp_Language_Index);
167 package Temp_Files is new Table.Table
168 (Table_Component_Type => Path_Name_Type,
169 Table_Index_Type => Integer,
170 Table_Low_Bound => 1,
171 Table_Initial => 20,
172 Table_Increment => 100,
173 Table_Name => "Makegpr.Temp_Files");
174 -- Table to store the path name of all the created temporary files, so that
175 -- they can be deleted at the end, or when the program is interrupted.
177 -----------------------
178 -- Add_Language_Name --
179 -----------------------
181 procedure Add_Language_Name (Name : Name_Id) is
182 begin
183 Last_Language_Index := Last_Language_Index + 1;
184 Language_Indexes.Set (Name, Last_Language_Index);
185 Language_Names.Increment_Last;
186 Language_Names.Table (Last_Language_Index) := Name;
187 end Add_Language_Name;
189 -------------------
190 -- Add_To_Buffer --
191 -------------------
193 procedure Add_To_Buffer
194 (S : String;
195 To : in out String_Access;
196 Last : in out Natural)
197 is
198 begin
199 if To = null then
200 To := new String (1 .. Initial_Buffer_Size);
201 Last := 0;
202 end if;
204 -- If Buffer is too small, double its size
206 while Last + S'Length > To'Last loop
207 declare
208 New_Buffer : constant String_Access :=
209 new String (1 .. 2 * Last);
211 begin
212 New_Buffer (1 .. Last) := To (1 .. Last);
213 Free (To);
214 To := New_Buffer;
215 end;
216 end loop;
218 To (Last + 1 .. Last + S'Length) := S;
219 Last := Last + S'Length;
220 end Add_To_Buffer;
222 -----------------------
223 -- Body_Suffix_Id_Of --
224 -----------------------
226 function Body_Suffix_Id_Of
227 (In_Tree : Project_Tree_Ref;
228 Language : String;
229 Naming : Naming_Data) return File_Name_Type
230 is
231 Language_Id : Name_Id;
233 begin
234 Name_Len := 0;
235 Add_Str_To_Name_Buffer (Language);
236 To_Lower (Name_Buffer (1 .. Name_Len));
237 Language_Id := Name_Find;
239 return
240 Body_Suffix_Id_Of
241 (In_Tree => In_Tree,
242 Language_Id => Language_Id,
243 Naming => Naming);
244 end Body_Suffix_Id_Of;
246 -----------------------
247 -- Body_Suffix_Id_Of --
248 -----------------------
250 function Body_Suffix_Id_Of
251 (In_Tree : Project_Tree_Ref;
252 Language_Id : Name_Id;
253 Naming : Naming_Data) return File_Name_Type
254 is
255 Element_Id : Array_Element_Id;
256 Element : Array_Element;
257 Suffix : File_Name_Type := No_File;
258 Lang : Language_Index;
260 begin
261 -- ??? This seems to be only for Ada_Only mode...
262 Element_Id := Naming.Body_Suffix;
263 while Element_Id /= No_Array_Element loop
264 Element := In_Tree.Array_Elements.Table (Element_Id);
266 if Element.Index = Language_Id then
267 return File_Name_Type (Element.Value.Value);
268 end if;
270 Element_Id := Element.Next;
271 end loop;
273 if Current_Mode = Multi_Language then
274 Lang := In_Tree.First_Language;
275 while Lang /= No_Language_Index loop
276 if In_Tree.Languages_Data.Table (Lang).Name = Language_Id then
277 Suffix :=
278 In_Tree.Languages_Data.Table
279 (Lang).Config.Naming_Data.Body_Suffix;
280 exit;
281 end if;
283 Lang := In_Tree.Languages_Data.Table (Lang).Next;
284 end loop;
285 end if;
287 return Suffix;
288 end Body_Suffix_Id_Of;
290 --------------------
291 -- Body_Suffix_Of --
292 --------------------
294 function Body_Suffix_Of
295 (In_Tree : Project_Tree_Ref;
296 Language : String;
297 Naming : Naming_Data) return String
298 is
299 Language_Id : Name_Id;
300 Element_Id : Array_Element_Id;
301 Element : Array_Element;
302 Suffix : File_Name_Type := No_File;
303 Lang : Language_Index;
305 begin
306 Name_Len := 0;
307 Add_Str_To_Name_Buffer (Language);
308 To_Lower (Name_Buffer (1 .. Name_Len));
309 Language_Id := Name_Find;
311 Element_Id := Naming.Body_Suffix;
312 while Element_Id /= No_Array_Element loop
313 Element := In_Tree.Array_Elements.Table (Element_Id);
315 if Element.Index = Language_Id then
316 return Get_Name_String (Element.Value.Value);
317 end if;
319 Element_Id := Element.Next;
320 end loop;
322 if Current_Mode = Multi_Language then
323 Lang := In_Tree.First_Language;
324 while Lang /= No_Language_Index loop
325 if In_Tree.Languages_Data.Table (Lang).Name = Language_Id then
326 Suffix :=
327 File_Name_Type
328 (In_Tree.Languages_Data.Table
329 (Lang).Config.Naming_Data.Body_Suffix);
330 exit;
331 end if;
333 Lang := In_Tree.Languages_Data.Table (Lang).Next;
334 end loop;
336 if Suffix /= No_File then
337 return Get_Name_String (Suffix);
338 end if;
339 end if;
341 return "";
342 end Body_Suffix_Of;
344 function Body_Suffix_Of
345 (Language : Language_Index;
346 In_Project : Project_Data;
347 In_Tree : Project_Tree_Ref) return String
348 is
349 Suffix_Id : constant File_Name_Type :=
350 Suffix_Of (Language, In_Project, In_Tree);
351 begin
352 if Suffix_Id /= No_File then
353 return Get_Name_String (Suffix_Id);
354 else
355 return "." & Get_Name_String (Language_Names.Table (Language));
356 end if;
357 end Body_Suffix_Of;
359 -----------------------------
360 -- Default_Ada_Body_Suffix --
361 -----------------------------
363 function Default_Ada_Body_Suffix return File_Name_Type is
364 begin
365 return Default_Ada_Body_Suffix_Id;
366 end Default_Ada_Body_Suffix;
368 -----------------------------
369 -- Default_Ada_Spec_Suffix --
370 -----------------------------
372 function Default_Ada_Spec_Suffix return File_Name_Type is
373 begin
374 return Default_Ada_Spec_Suffix_Id;
375 end Default_Ada_Spec_Suffix;
377 ---------------------------
378 -- Delete_All_Temp_Files --
379 ---------------------------
381 procedure Delete_All_Temp_Files is
382 Dont_Care : Boolean;
383 pragma Warnings (Off, Dont_Care);
384 begin
385 if not Debug.Debug_Flag_N then
386 for Index in 1 .. Temp_Files.Last loop
387 Delete_File
388 (Get_Name_String (Temp_Files.Table (Index)), Dont_Care);
389 end loop;
390 end if;
391 end Delete_All_Temp_Files;
393 ---------------------
394 -- Dependency_Name --
395 ---------------------
397 function Dependency_Name
398 (Source_File_Name : File_Name_Type;
399 Dependency : Dependency_File_Kind) return File_Name_Type
400 is
401 begin
402 case Dependency is
403 when None =>
404 return No_File;
406 when Makefile =>
407 return
408 File_Name_Type
409 (Extend_Name
410 (Source_File_Name, Makefile_Dependency_Suffix));
412 when ALI_File =>
413 return
414 File_Name_Type
415 (Extend_Name
416 (Source_File_Name, ALI_Dependency_Suffix));
417 end case;
418 end Dependency_Name;
420 ---------------------------
421 -- Display_Language_Name --
422 ---------------------------
424 procedure Display_Language_Name
425 (In_Tree : Project_Tree_Ref;
426 Language : Language_Index)
427 is
428 begin
429 Get_Name_String (In_Tree.Languages_Data.Table (Language).Display_Name);
430 Write_Str (Name_Buffer (1 .. Name_Len));
431 end Display_Language_Name;
433 ---------------------------
434 -- Display_Language_Name --
435 ---------------------------
437 procedure Display_Language_Name (Language : Language_Index) is
438 begin
439 Get_Name_String (Language_Names.Table (Language));
440 To_Upper (Name_Buffer (1 .. 1));
441 Write_Str (Name_Buffer (1 .. Name_Len));
442 end Display_Language_Name;
444 ----------------
445 -- Empty_File --
446 ----------------
448 function Empty_File return File_Name_Type is
449 begin
450 return File_Name_Type (The_Empty_String);
451 end Empty_File;
453 -------------------
454 -- Empty_Project --
455 -------------------
457 function Empty_Project (Tree : Project_Tree_Ref) return Project_Data is
458 Value : Project_Data;
460 begin
461 Prj.Initialize (Tree => No_Project_Tree);
462 Value := Project_Empty;
463 Value.Naming := Tree.Private_Part.Default_Naming;
465 return Value;
466 end Empty_Project;
468 ------------------
469 -- Empty_String --
470 ------------------
472 function Empty_String return Name_Id is
473 begin
474 return The_Empty_String;
475 end Empty_String;
477 ------------
478 -- Expect --
479 ------------
481 procedure Expect (The_Token : Token_Type; Token_Image : String) is
482 begin
483 if Token /= The_Token then
484 Error_Msg (Token_Image & " expected", Token_Ptr);
485 end if;
486 end Expect;
488 -----------------
489 -- Extend_Name --
490 -----------------
492 function Extend_Name
493 (File : File_Name_Type;
494 With_Suffix : String) return File_Name_Type
495 is
496 Last : Positive;
498 begin
499 Get_Name_String (File);
500 Last := Name_Len + 1;
503 Name_Len := Name_Len - 1;
504 end loop;
506 if Name_Len <= 1 then
507 Name_Len := Last;
508 end if;
510 for J in With_Suffix'Range loop
511 Name_Buffer (Name_Len) := With_Suffix (J);
512 Name_Len := Name_Len + 1;
513 end loop;
515 Name_Len := Name_Len - 1;
516 return Name_Find;
518 end Extend_Name;
520 --------------------------------
521 -- For_Every_Project_Imported --
522 --------------------------------
524 procedure For_Every_Project_Imported
525 (By : Project_Id;
526 In_Tree : Project_Tree_Ref;
527 With_State : in out State)
528 is
530 procedure Recursive_Check (Project : Project_Id);
531 -- Check if a project has already been seen. If not seen, mark it as
532 -- Seen, Call Action, and check all its imported projects.
534 ---------------------
535 -- Recursive_Check --
536 ---------------------
538 procedure Recursive_Check (Project : Project_Id) is
539 List : Project_List;
540 begin
541 if not In_Tree.Projects.Table (Project).Seen then
542 In_Tree.Projects.Table (Project).Seen := True;
543 Action (Project, With_State);
545 List := In_Tree.Projects.Table (Project).Imported_Projects;
546 while List /= Empty_Project_List loop
547 Recursive_Check (In_Tree.Project_Lists.Table (List).Project);
548 List := In_Tree.Project_Lists.Table (List).Next;
549 end loop;
550 end if;
551 end Recursive_Check;
553 -- Start of processing for For_Every_Project_Imported
555 begin
556 for Project in Project_Table.First ..
557 Project_Table.Last (In_Tree.Projects)
558 loop
559 In_Tree.Projects.Table (Project).Seen := False;
560 end loop;
562 Recursive_Check (Project => By);
563 end For_Every_Project_Imported;
565 --------------
566 -- Get_Mode --
567 --------------
569 function Get_Mode return Mode is
570 begin
571 return Current_Mode;
572 end Get_Mode;
574 ----------
575 -- Hash --
576 ----------
578 function Hash is new System.HTable.Hash (Header_Num => Header_Num);
579 -- Used in implementation of other functions Hash below
581 function Hash (Name : File_Name_Type) return Header_Num is
582 begin
583 return Hash (Get_Name_String (Name));
584 end Hash;
586 function Hash (Name : Name_Id) return Header_Num is
587 begin
588 return Hash (Get_Name_String (Name));
589 end Hash;
591 function Hash (Name : Path_Name_Type) return Header_Num is
592 begin
593 return Hash (Get_Name_String (Name));
594 end Hash;
596 function Hash (Project : Project_Id) return Header_Num is
597 begin
598 return Header_Num (Project mod Max_Header_Num);
599 end Hash;
601 -----------
602 -- Image --
603 -----------
605 function Image (Casing : Casing_Type) return String is
606 begin
607 return The_Casing_Images (Casing).all;
608 end Image;
610 ----------------------
611 -- In_Configuration --
612 ----------------------
614 function In_Configuration return Boolean is
615 begin
616 return Configuration_Mode;
617 end In_Configuration;
619 ----------------
620 -- Initialize --
621 ----------------
623 procedure Initialize (Tree : Project_Tree_Ref) is
624 begin
625 if not Initialized then
626 Initialized := True;
627 Uintp.Initialize;
628 Name_Len := 0;
629 The_Empty_String := Name_Find;
630 Empty_Name := The_Empty_String;
631 Empty_File_Name := File_Name_Type (The_Empty_String);
632 Name_Len := 4;
633 Name_Buffer (1 .. 4) := ".ads";
634 Default_Ada_Spec_Suffix_Id := Name_Find;
635 Name_Len := 4;
636 Name_Buffer (1 .. 4) := ".adb";
637 Default_Ada_Body_Suffix_Id := Name_Find;
638 Name_Len := 1;
640 Slash_Id := Name_Find;
641 Name_Len := 3;
642 Name_Buffer (1 .. 3) := "c++";
643 Name_C_Plus_Plus := Name_Find;
645 Prj.Env.Initialize;
646 Prj.Attr.Initialize;
647 Set_Name_Table_Byte (Name_Project, Token_Type'Pos (Tok_Project));
648 Set_Name_Table_Byte (Name_Extends, Token_Type'Pos (Tok_Extends));
649 Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External));
651 Language_Indexes.Reset;
652 Last_Language_Index := No_Language_Index;
653 Language_Names.Init;
654 Add_Language_Name (Name_Ada);
655 Add_Language_Name (Name_C);
656 Add_Language_Name (Name_C_Plus_Plus);
657 end if;
659 if Tree /= No_Project_Tree then
660 Reset (Tree);
661 end if;
662 end Initialize;
664 -------------------
665 -- Is_A_Language --
666 -------------------
668 function Is_A_Language
669 (Tree : Project_Tree_Ref;
670 Data : Project_Data;
671 Language_Name : Name_Id) return Boolean
672 is
673 begin
674 if Get_Mode = Ada_Only then
675 declare
676 List : Name_List_Index := Data.Languages;
677 begin
678 while List /= No_Name_List loop
679 if Tree.Name_Lists.Table (List).Name = Language_Name then
680 return True;
681 else
682 List := Tree.Name_Lists.Table (List).Next;
683 end if;
684 end loop;
685 end;
687 else
688 declare
689 Lang_Ind : Language_Index := Data.First_Language_Processing;
690 Lang_Data : Language_Data;
692 begin
693 while Lang_Ind /= No_Language_Index loop
694 Lang_Data := Tree.Languages_Data.Table (Lang_Ind);
696 if Lang_Data.Name = Language_Name then
697 return True;
698 end if;
700 Lang_Ind := Lang_Data.Next;
701 end loop;
702 end;
703 end if;
705 return False;
706 end Is_A_Language;
708 ------------------
709 -- Is_Extending --
710 ------------------
712 function Is_Extending
713 (Extending : Project_Id;
714 Extended : Project_Id;
715 In_Tree : Project_Tree_Ref) return Boolean
716 is
717 Proj : Project_Id;
719 begin
720 Proj := Extending;
721 while Proj /= No_Project loop
722 if Proj = Extended then
723 return True;
724 end if;
726 Proj := In_Tree.Projects.Table (Proj).Extends;
727 end loop;
729 return False;
730 end Is_Extending;
732 ----------------
733 -- Is_Present --
734 ----------------
736 function Is_Present
737 (Language : Language_Index;
738 In_Project : Project_Data;
739 In_Tree : Project_Tree_Ref) return Boolean
740 is
741 begin
742 case Language is
743 when No_Language_Index =>
744 return False;
746 when First_Language_Indexes =>
747 return In_Project.Langs (Language);
749 when others =>
750 declare
751 Supp : Supp_Language;
752 Supp_Index : Supp_Language_Index;
754 begin
755 Supp_Index := In_Project.Supp_Languages;
756 while Supp_Index /= No_Supp_Language_Index loop
757 Supp := In_Tree.Present_Languages.Table (Supp_Index);
759 if Supp.Index = Language then
760 return Supp.Present;
761 end if;
763 Supp_Index := Supp.Next;
764 end loop;
766 return False;
767 end;
768 end case;
769 end Is_Present;
771 ---------------------------------
772 -- Language_Processing_Data_Of --
773 ---------------------------------
775 function Language_Processing_Data_Of
776 (Language : Language_Index;
777 In_Project : Project_Data;
778 In_Tree : Project_Tree_Ref) return Language_Processing_Data
779 is
780 begin
781 case Language is
782 when No_Language_Index =>
783 return Default_Language_Processing_Data;
785 when First_Language_Indexes =>
786 return In_Project.First_Lang_Processing (Language);
788 when others =>
789 declare
790 Supp : Supp_Language_Data;
791 Supp_Index : Supp_Language_Index;
793 begin
794 Supp_Index := In_Project.Supp_Language_Processing;
795 while Supp_Index /= No_Supp_Language_Index loop
796 Supp := In_Tree.Supp_Languages.Table (Supp_Index);
798 if Supp.Index = Language then
799 return Supp.Data;
800 end if;
802 Supp_Index := Supp.Next;
803 end loop;
805 return Default_Language_Processing_Data;
806 end;
807 end case;
808 end Language_Processing_Data_Of;
810 -----------------------
811 -- Objects_Exist_For --
812 -----------------------
814 function Objects_Exist_For
815 (Language : String;
816 In_Tree : Project_Tree_Ref) return Boolean
817 is
818 Language_Id : Name_Id;
819 Lang : Language_Index;
821 begin
822 if Current_Mode = Multi_Language then
823 Name_Len := 0;
824 Add_Str_To_Name_Buffer (Language);
825 To_Lower (Name_Buffer (1 .. Name_Len));
826 Language_Id := Name_Find;
828 Lang := In_Tree.First_Language;
829 while Lang /= No_Language_Index loop
830 if In_Tree.Languages_Data.Table (Lang).Name = Language_Id then
831 return
832 In_Tree.Languages_Data.Table
833 (Lang).Config.Objects_Generated;
834 end if;
836 Lang := In_Tree.Languages_Data.Table (Lang).Next;
837 end loop;
838 end if;
840 return True;
841 end Objects_Exist_For;
843 -----------------
844 -- Object_Name --
845 -----------------
847 function Object_Name
848 (Source_File_Name : File_Name_Type)
849 return File_Name_Type
850 is
851 begin
852 return Extend_Name (Source_File_Name, Object_Suffix);
853 end Object_Name;
855 ----------------------
856 -- Record_Temp_File --
857 ----------------------
859 procedure Record_Temp_File (Path : Path_Name_Type) is
860 begin
861 Temp_Files.Increment_Last;
862 Temp_Files.Table (Temp_Files.Last) := Path;
863 end Record_Temp_File;
865 ------------------------------------
866 -- Register_Default_Naming_Scheme --
867 ------------------------------------
869 procedure Register_Default_Naming_Scheme
870 (Language : Name_Id;
871 Default_Spec_Suffix : File_Name_Type;
872 Default_Body_Suffix : File_Name_Type;
873 In_Tree : Project_Tree_Ref)
874 is
875 Lang : Name_Id;
876 Suffix : Array_Element_Id;
877 Found : Boolean := False;
878 Element : Array_Element;
880 begin
881 -- Get the language name in small letters
883 Get_Name_String (Language);
884 Name_Buffer (1 .. Name_Len) := To_Lower (Name_Buffer (1 .. Name_Len));
885 Lang := Name_Find;
887 -- Look for an element of the spec suffix array indexed by the language
888 -- name. If one is found, put the default value.
890 Suffix := In_Tree.Private_Part.Default_Naming.Spec_Suffix;
891 Found := False;
892 while Suffix /= No_Array_Element and then not Found loop
893 Element := In_Tree.Array_Elements.Table (Suffix);
895 if Element.Index = Lang then
896 Found := True;
897 Element.Value.Value := Name_Id (Default_Spec_Suffix);
898 In_Tree.Array_Elements.Table (Suffix) := Element;
900 else
901 Suffix := Element.Next;
902 end if;
903 end loop;
905 -- If none can be found, create a new one
907 if not Found then
908 Element :=
909 (Index => Lang,
910 Src_Index => 0,
911 Index_Case_Sensitive => False,
912 Value => (Project => No_Project,
913 Kind => Single,
914 Location => No_Location,
915 Default => False,
916 Value => Name_Id (Default_Spec_Suffix),
917 Index => 0),
918 Next => In_Tree.Private_Part.Default_Naming.Spec_Suffix);
919 Array_Element_Table.Increment_Last (In_Tree.Array_Elements);
920 In_Tree.Array_Elements.Table
921 (Array_Element_Table.Last (In_Tree.Array_Elements)) :=
922 Element;
923 In_Tree.Private_Part.Default_Naming.Spec_Suffix :=
924 Array_Element_Table.Last (In_Tree.Array_Elements);
925 end if;
927 -- Look for an element of the body suffix array indexed by the language
928 -- name. If one is found, put the default value.
930 Suffix := In_Tree.Private_Part.Default_Naming.Body_Suffix;
931 Found := False;
932 while Suffix /= No_Array_Element and then not Found loop
933 Element := In_Tree.Array_Elements.Table (Suffix);
935 if Element.Index = Lang then
936 Found := True;
937 Element.Value.Value := Name_Id (Default_Body_Suffix);
938 In_Tree.Array_Elements.Table (Suffix) := Element;
940 else
941 Suffix := Element.Next;
942 end if;
943 end loop;
945 -- If none can be found, create a new one
947 if not Found then
948 Element :=
949 (Index => Lang,
950 Src_Index => 0,
951 Index_Case_Sensitive => False,
952 Value => (Project => No_Project,
953 Kind => Single,
954 Location => No_Location,
955 Default => False,
956 Value => Name_Id (Default_Body_Suffix),
957 Index => 0),
958 Next => In_Tree.Private_Part.Default_Naming.Body_Suffix);
959 Array_Element_Table.Increment_Last
960 (In_Tree.Array_Elements);
961 In_Tree.Array_Elements.Table
962 (Array_Element_Table.Last (In_Tree.Array_Elements))
963 := Element;
964 In_Tree.Private_Part.Default_Naming.Body_Suffix :=
965 Array_Element_Table.Last (In_Tree.Array_Elements);
966 end if;
967 end Register_Default_Naming_Scheme;
969 -----------
970 -- Reset --
971 -----------
973 procedure Reset (Tree : Project_Tree_Ref) is
975 -- Def_Lang : constant Name_Node :=
976 -- (Name => Name_Ada,
977 -- Next => No_Name_List);
978 -- Why is the above commented out ???
980 begin
981 Prj.Env.Initialize;
983 -- gprmake tables
985 Present_Language_Table.Init (Tree.Present_Languages);
986 Supp_Suffix_Table.Init (Tree.Supp_Suffixes);
987 Supp_Language_Table.Init (Tree.Supp_Languages);
988 Other_Source_Table.Init (Tree.Other_Sources);
990 -- Visible tables
992 Language_Data_Table.Init (Tree.Languages_Data);
993 Name_List_Table.Init (Tree.Name_Lists);
994 String_Element_Table.Init (Tree.String_Elements);
995 Variable_Element_Table.Init (Tree.Variable_Elements);
996 Array_Element_Table.Init (Tree.Array_Elements);
997 Array_Table.Init (Tree.Arrays);
998 Package_Table.Init (Tree.Packages);
999 Project_List_Table.Init (Tree.Project_Lists);
1000 Project_Table.Init (Tree.Projects);
1001 Source_Data_Table.Init (Tree.Sources);
1002 Alternate_Language_Table.Init (Tree.Alt_Langs);
1003 Unit_Table.Init (Tree.Units);
1004 Units_Htable.Reset (Tree.Units_HT);
1005 Files_Htable.Reset (Tree.Files_HT);
1006 Source_Paths_Htable.Reset (Tree.Source_Paths_HT);
1008 -- Private part table
1010 Naming_Table.Init (Tree.Private_Part.Namings);
1011 Naming_Table.Increment_Last (Tree.Private_Part.Namings);
1012 Tree.Private_Part.Namings.Table
1013 (Naming_Table.Last (Tree.Private_Part.Namings)) := Std_Naming_Data;
1014 Path_File_Table.Init (Tree.Private_Part.Path_Files);
1015 Source_Path_Table.Init (Tree.Private_Part.Source_Paths);
1016 Object_Path_Table.Init (Tree.Private_Part.Object_Paths);
1017 Tree.Private_Part.Default_Naming := Std_Naming_Data;
1019 if Current_Mode = Ada_Only then
1020 Register_Default_Naming_Scheme
1021 (Language => Name_Ada,
1022 Default_Spec_Suffix => Default_Ada_Spec_Suffix,
1023 Default_Body_Suffix => Default_Ada_Body_Suffix,
1024 In_Tree => Tree);
1025 Tree.Private_Part.Default_Naming.Separate_Suffix :=
1026 Default_Ada_Body_Suffix;
1027 end if;
1028 end Reset;
1030 ------------------------
1031 -- Same_Naming_Scheme --
1032 ------------------------
1034 function Same_Naming_Scheme
1035 (Left, Right : Naming_Data) return Boolean
1036 is
1037 begin
1038 return Left.Dot_Replacement = Right.Dot_Replacement
1039 and then Left.Casing = Right.Casing
1040 and then Left.Separate_Suffix = Right.Separate_Suffix;
1041 end Same_Naming_Scheme;
1043 ---------
1044 -- Set --
1045 ---------
1047 procedure Set
1048 (Language : Language_Index;
1049 Present : Boolean;
1050 In_Project : in out Project_Data;
1051 In_Tree : Project_Tree_Ref)
1052 is
1053 begin
1054 case Language is
1055 when No_Language_Index =>
1056 null;
1058 when First_Language_Indexes =>
1059 In_Project.Langs (Language) := Present;
1061 when others =>
1062 declare
1063 Supp : Supp_Language;
1064 Supp_Index : Supp_Language_Index;
1066 begin
1067 Supp_Index := In_Project.Supp_Languages;
1068 while Supp_Index /= No_Supp_Language_Index loop
1069 Supp := In_Tree.Present_Languages.Table (Supp_Index);
1071 if Supp.Index = Language then
1072 In_Tree.Present_Languages.Table (Supp_Index).Present :=
1073 Present;
1074 return;
1075 end if;
1077 Supp_Index := Supp.Next;
1078 end loop;
1080 Supp := (Index => Language, Present => Present,
1081 Next => In_Project.Supp_Languages);
1082 Present_Language_Table.Increment_Last
1083 (In_Tree.Present_Languages);
1084 Supp_Index :=
1085 Present_Language_Table.Last (In_Tree.Present_Languages);
1086 In_Tree.Present_Languages.Table (Supp_Index) :=
1087 Supp;
1088 In_Project.Supp_Languages := Supp_Index;
1089 end;
1090 end case;
1091 end Set;
1093 procedure Set
1094 (Language_Processing : Language_Processing_Data;
1095 For_Language : Language_Index;
1096 In_Project : in out Project_Data;
1097 In_Tree : Project_Tree_Ref)
1098 is
1099 begin
1100 case For_Language is
1101 when No_Language_Index =>
1102 null;
1104 when First_Language_Indexes =>
1105 In_Project.First_Lang_Processing (For_Language) :=
1106 Language_Processing;
1108 when others =>
1109 declare
1110 Supp : Supp_Language_Data;
1111 Supp_Index : Supp_Language_Index;
1113 begin
1114 Supp_Index := In_Project.Supp_Language_Processing;
1115 while Supp_Index /= No_Supp_Language_Index loop
1116 Supp := In_Tree.Supp_Languages.Table (Supp_Index);
1118 if Supp.Index = For_Language then
1119 In_Tree.Supp_Languages.Table
1120 (Supp_Index).Data := Language_Processing;
1121 return;
1122 end if;
1124 Supp_Index := Supp.Next;
1125 end loop;
1127 Supp := (Index => For_Language, Data => Language_Processing,
1128 Next => In_Project.Supp_Language_Processing);
1129 Supp_Language_Table.Increment_Last
1130 (In_Tree.Supp_Languages);
1131 Supp_Index := Supp_Language_Table.Last
1132 (In_Tree.Supp_Languages);
1133 In_Tree.Supp_Languages.Table (Supp_Index) := Supp;
1134 In_Project.Supp_Language_Processing := Supp_Index;
1135 end;
1136 end case;
1137 end Set;
1139 procedure Set
1140 (Suffix : File_Name_Type;
1141 For_Language : Language_Index;
1142 In_Project : in out Project_Data;
1143 In_Tree : Project_Tree_Ref)
1144 is
1145 begin
1146 case For_Language is
1147 when No_Language_Index =>
1148 null;
1150 when First_Language_Indexes =>
1151 In_Project.Naming.Impl_Suffixes (For_Language) := Suffix;
1153 when others =>
1154 declare
1155 Supp : Supp_Suffix;
1156 Supp_Index : Supp_Language_Index;
1158 begin
1159 Supp_Index := In_Project.Naming.Supp_Suffixes;
1160 while Supp_Index /= No_Supp_Language_Index loop
1161 Supp := In_Tree.Supp_Suffixes.Table (Supp_Index);
1163 if Supp.Index = For_Language then
1164 In_Tree.Supp_Suffixes.Table (Supp_Index).Suffix := Suffix;
1165 return;
1166 end if;
1168 Supp_Index := Supp.Next;
1169 end loop;
1171 Supp := (Index => For_Language, Suffix => Suffix,
1172 Next => In_Project.Naming.Supp_Suffixes);
1173 Supp_Suffix_Table.Increment_Last (In_Tree.Supp_Suffixes);
1174 Supp_Index := Supp_Suffix_Table.Last (In_Tree.Supp_Suffixes);
1175 In_Tree.Supp_Suffixes.Table (Supp_Index) := Supp;
1176 In_Project.Naming.Supp_Suffixes := Supp_Index;
1177 end;
1178 end case;
1179 end Set;
1181 ---------------------
1182 -- Set_Body_Suffix --
1183 ---------------------
1185 procedure Set_Body_Suffix
1186 (In_Tree : Project_Tree_Ref;
1187 Language : String;
1188 Naming : in out Naming_Data;
1189 Suffix : File_Name_Type)
1190 is
1191 Language_Id : Name_Id;
1192 Element : Array_Element;
1194 begin
1195 Name_Len := 0;
1196 Add_Str_To_Name_Buffer (Language);
1197 To_Lower (Name_Buffer (1 .. Name_Len));
1198 Language_Id := Name_Find;
1200 Element :=
1201 (Index => Language_Id,
1202 Src_Index => 0,
1203 Index_Case_Sensitive => False,
1204 Value =>
1205 (Kind => Single,
1206 Project => No_Project,
1207 Location => No_Location,
1208 Default => False,
1209 Value => Name_Id (Suffix),
1210 Index => 0),
1211 Next => Naming.Body_Suffix);
1213 Array_Element_Table.Increment_Last (In_Tree.Array_Elements);
1214 Naming.Body_Suffix :=
1215 Array_Element_Table.Last (In_Tree.Array_Elements);
1216 In_Tree.Array_Elements.Table (Naming.Body_Suffix) := Element;
1217 end Set_Body_Suffix;
1219 --------------------------
1220 -- Set_In_Configuration --
1221 --------------------------
1223 procedure Set_In_Configuration (Value : Boolean) is
1224 begin
1225 Configuration_Mode := Value;
1226 end Set_In_Configuration;
1228 --------------
1229 -- Set_Mode --
1230 --------------
1232 procedure Set_Mode (New_Mode : Mode) is
1233 begin
1234 Current_Mode := New_Mode;
1235 case New_Mode is
1236 when Ada_Only =>
1237 Default_Language_Is_Ada := True;
1238 Must_Check_Configuration := False;
1239 when Multi_Language =>
1240 Default_Language_Is_Ada := False;
1241 Must_Check_Configuration := True;
1242 end case;
1243 end Set_Mode;
1245 ---------------------
1246 -- Set_Spec_Suffix --
1247 ---------------------
1249 procedure Set_Spec_Suffix
1250 (In_Tree : Project_Tree_Ref;
1251 Language : String;
1252 Naming : in out Naming_Data;
1253 Suffix : File_Name_Type)
1254 is
1255 Language_Id : Name_Id;
1256 Element : Array_Element;
1258 begin
1259 Name_Len := 0;
1260 Add_Str_To_Name_Buffer (Language);
1261 To_Lower (Name_Buffer (1 .. Name_Len));
1262 Language_Id := Name_Find;
1264 Element :=
1265 (Index => Language_Id,
1266 Src_Index => 0,
1267 Index_Case_Sensitive => False,
1268 Value =>
1269 (Kind => Single,
1270 Project => No_Project,
1271 Location => No_Location,
1272 Default => False,
1273 Value => Name_Id (Suffix),
1274 Index => 0),
1275 Next => Naming.Spec_Suffix);
1277 Array_Element_Table.Increment_Last (In_Tree.Array_Elements);
1278 Naming.Spec_Suffix :=
1279 Array_Element_Table.Last (In_Tree.Array_Elements);
1280 In_Tree.Array_Elements.Table (Naming.Spec_Suffix) := Element;
1281 end Set_Spec_Suffix;
1283 -----------
1284 -- Slash --
1285 -----------
1287 function Slash return Path_Name_Type is
1288 begin
1289 return Slash_Id;
1290 end Slash;
1292 -----------------------
1293 -- Spec_Suffix_Id_Of --
1294 -----------------------
1296 function Spec_Suffix_Id_Of
1297 (In_Tree : Project_Tree_Ref;
1298 Language : String;
1299 Naming : Naming_Data) return File_Name_Type
1300 is
1301 Language_Id : Name_Id;
1303 begin
1304 Name_Len := 0;
1305 Add_Str_To_Name_Buffer (Language);
1306 To_Lower (Name_Buffer (1 .. Name_Len));
1307 Language_Id := Name_Find;
1309 return
1310 Spec_Suffix_Id_Of
1311 (In_Tree => In_Tree,
1312 Language_Id => Language_Id,
1313 Naming => Naming);
1314 end Spec_Suffix_Id_Of;
1316 -----------------------
1317 -- Spec_Suffix_Id_Of --
1318 -----------------------
1320 function Spec_Suffix_Id_Of
1321 (In_Tree : Project_Tree_Ref;
1322 Language_Id : Name_Id;
1323 Naming : Naming_Data) return File_Name_Type
1324 is
1325 Element_Id : Array_Element_Id;
1326 Element : Array_Element;
1327 Suffix : File_Name_Type := No_File;
1328 Lang : Language_Index;
1330 begin
1331 Element_Id := Naming.Spec_Suffix;
1332 while Element_Id /= No_Array_Element loop
1333 Element := In_Tree.Array_Elements.Table (Element_Id);
1335 if Element.Index = Language_Id then
1336 return File_Name_Type (Element.Value.Value);
1337 end if;
1339 Element_Id := Element.Next;
1340 end loop;
1342 if Current_Mode = Multi_Language then
1343 Lang := In_Tree.First_Language;
1344 while Lang /= No_Language_Index loop
1345 if In_Tree.Languages_Data.Table (Lang).Name = Language_Id then
1346 Suffix :=
1347 In_Tree.Languages_Data.Table
1348 (Lang).Config.Naming_Data.Spec_Suffix;
1349 exit;
1350 end if;
1352 Lang := In_Tree.Languages_Data.Table (Lang).Next;
1353 end loop;
1354 end if;
1356 return Suffix;
1357 end Spec_Suffix_Id_Of;
1359 --------------------
1360 -- Spec_Suffix_Of --
1361 --------------------
1363 function Spec_Suffix_Of
1364 (In_Tree : Project_Tree_Ref;
1365 Language : String;
1366 Naming : Naming_Data) return String
1367 is
1368 Language_Id : Name_Id;
1369 Element_Id : Array_Element_Id;
1370 Element : Array_Element;
1371 Suffix : File_Name_Type := No_File;
1372 Lang : Language_Index;
1374 begin
1375 Name_Len := 0;
1376 Add_Str_To_Name_Buffer (Language);
1377 To_Lower (Name_Buffer (1 .. Name_Len));
1378 Language_Id := Name_Find;
1380 Element_Id := Naming.Spec_Suffix;
1381 while Element_Id /= No_Array_Element loop
1382 Element := In_Tree.Array_Elements.Table (Element_Id);
1384 if Element.Index = Language_Id then
1385 return Get_Name_String (Element.Value.Value);
1386 end if;
1388 Element_Id := Element.Next;
1389 end loop;
1391 if Current_Mode = Multi_Language then
1392 Lang := In_Tree.First_Language;
1393 while Lang /= No_Language_Index loop
1394 if In_Tree.Languages_Data.Table (Lang).Name = Language_Id then
1395 Suffix :=
1396 File_Name_Type
1397 (In_Tree.Languages_Data.Table
1398 (Lang).Config.Naming_Data.Spec_Suffix);
1399 exit;
1400 end if;
1402 Lang := In_Tree.Languages_Data.Table (Lang).Next;
1403 end loop;
1405 if Suffix /= No_File then
1406 return Get_Name_String (Suffix);
1407 end if;
1408 end if;
1410 return "";
1411 end Spec_Suffix_Of;
1413 --------------------------
1414 -- Standard_Naming_Data --
1415 --------------------------
1417 function Standard_Naming_Data
1418 (Tree : Project_Tree_Ref := No_Project_Tree) return Naming_Data
1419 is
1420 begin
1421 if Tree = No_Project_Tree then
1422 Prj.Initialize (Tree => No_Project_Tree);
1423 return Std_Naming_Data;
1424 else
1425 return Tree.Private_Part.Default_Naming;
1426 end if;
1427 end Standard_Naming_Data;
1429 ---------------
1430 -- Suffix_Of --
1431 ---------------
1433 function Suffix_Of
1434 (Language : Language_Index;
1435 In_Project : Project_Data;
1436 In_Tree : Project_Tree_Ref) return File_Name_Type
1437 is
1438 begin
1439 case Language is
1440 when No_Language_Index =>
1441 return No_File;
1443 when First_Language_Indexes =>
1444 return In_Project.Naming.Impl_Suffixes (Language);
1446 when others =>
1447 declare
1448 Supp : Supp_Suffix;
1449 Supp_Index : Supp_Language_Index;
1451 begin
1452 Supp_Index := In_Project.Naming.Supp_Suffixes;
1453 while Supp_Index /= No_Supp_Language_Index loop
1454 Supp := In_Tree.Supp_Suffixes.Table (Supp_Index);
1456 if Supp.Index = Language then
1457 return Supp.Suffix;
1458 end if;
1460 Supp_Index := Supp.Next;
1461 end loop;
1463 return No_File;
1464 end;
1465 end case;
1466 end Suffix_Of;
1468 -------------------
1469 -- Switches_Name --
1470 -------------------
1472 function Switches_Name
1473 (Source_File_Name : File_Name_Type) return File_Name_Type
1474 is
1475 begin
1476 return Extend_Name (Source_File_Name, Switches_Dependency_Suffix);
1477 end Switches_Name;
1479 ---------------------------
1480 -- There_Are_Ada_Sources --
1481 ---------------------------
1483 function There_Are_Ada_Sources
1484 (In_Tree : Project_Tree_Ref;
1485 Project : Project_Id) return Boolean
1486 is
1487 Prj : Project_Id;
1489 begin
1490 Prj := Project;
1491 while Prj /= No_Project loop
1492 if In_Tree.Projects.Table (Prj).Ada_Sources /= Nil_String then
1493 return True;
1494 end if;
1496 Prj := In_Tree.Projects.Table (Prj).Extends;
1497 end loop;
1499 return False;
1500 end There_Are_Ada_Sources;
1502 -----------
1503 -- Value --
1504 -----------
1506 function Value (Image : String) return Casing_Type is
1507 begin
1508 for Casing in The_Casing_Images'Range loop
1509 if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then
1510 return Casing;
1511 end if;
1512 end loop;
1514 raise Constraint_Error;
1515 end Value;
1517 begin
1518 -- Make sure that the standard config and user project file extensions are
1519 -- compatible with canonical case file naming.
1521 Canonical_Case_File_Name (Config_Project_File_Extension);
1522 Canonical_Case_File_Name (Project_File_Extension);
1523 end Prj;