projects / gcc.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
[multiple changes]
[gcc.git] / gcc / ada / prj.adb
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 ------------------------------------------------------------------------------
25
26 with Ada.Characters.Handling; use Ada.Characters.Handling;
27 with Ada.Unchecked_Deallocation;
28
29 with Debug;
30 with Output; use Output;
31 with Osint; use Osint;
32 with Prj.Attr;
33 with Prj.Env;
34 with Prj.Err; use Prj.Err;
35 with Snames; use Snames;
36 with Table;
37 with Uintp; use Uintp;
38
39 with System.Case_Util; use System.Case_Util;
40 with System.HTable;
41
42 package body Prj is
43
44 Object_Suffix : constant String := Get_Target_Object_Suffix.all;
45 -- File suffix for object files
46
47 Initial_Buffer_Size : constant := 100;
48 -- Initial size for extensible buffer used in Add_To_Buffer
49
50 Current_Mode : Mode := Ada_Only;
51
52 Configuration_Mode : Boolean := False;
53
54 The_Empty_String : Name_Id;
55
56 Default_Ada_Spec_Suffix_Id : File_Name_Type;
57 Default_Ada_Body_Suffix_Id : File_Name_Type;
58 Slash_Id : Path_Name_Type;
59 -- Initialized in Prj.Initialize, then never modified
60
61 subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case;
62
63 The_Casing_Images : constant array (Known_Casing) of String_Access :=
64 (All_Lower_Case => new String'("lowercase"),
65 All_Upper_Case => new String'("UPPERCASE"),
66 Mixed_Case => new String'("MixedCase"));
67
68 Initialized : Boolean := False;
69
70 Standard_Dot_Replacement : constant File_Name_Type :=
71 File_Name_Type
72 (First_Name_Id + Character'Pos ('-'));
73
74 Std_Naming_Data : constant Naming_Data :=
75 (Dot_Replacement => Standard_Dot_Replacement,
76 Dot_Repl_Loc => No_Location,
77 Casing => All_Lower_Case,
78 Spec_Suffix => No_Array_Element,
79 Ada_Spec_Suffix_Loc => No_Location,
80 Body_Suffix => No_Array_Element,
81 Ada_Body_Suffix_Loc => No_Location,
82 Separate_Suffix => No_File,
83 Sep_Suffix_Loc => No_Location,
84 Specs => No_Array_Element,
85 Bodies => No_Array_Element,
86 Specification_Exceptions => No_Array_Element,
87 Implementation_Exceptions => No_Array_Element);
88
89 Project_Empty : constant Project_Data :=
90 (Qualifier => Unspecified,
91 Externally_Built => False,
92 Config => Default_Project_Config,
93 Languages => No_Name_List,
94 First_Referred_By => No_Project,
95 Name => No_Name,
96 Display_Name => No_Name,
97 Path => No_Path_Information,
98 Virtual => False,
99 Location => No_Location,
100 Mains => Nil_String,
101 Directory => No_Path_Information,
102 Dir_Path => null,
103 Library => False,
104 Library_Dir => No_Path_Information,
105 Library_Src_Dir => No_Path_Information,
106 Library_ALI_Dir => No_Path_Information,
107 Library_Name => No_Name,
108 Library_Kind => Static,
109 Lib_Internal_Name => No_Name,
110 Standalone_Library => False,
111 Lib_Interface_ALIs => Nil_String,
112 Lib_Auto_Init => False,
113 Libgnarl_Needed => Unknown,
114 Symbol_Data => No_Symbols,
115 Ada_Sources_Present => True,
116 Other_Sources_Present => True,
117 Ada_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 Config_Checked => False,
148 Checked => False,
149 Seen => False,
150 Need_To_Build_Lib => False,
151 Depth => 0,
152 Unkept_Comments => False);
153
154 package Temp_Files is new Table.Table
155 (Table_Component_Type => Path_Name_Type,
156 Table_Index_Type => Integer,
157 Table_Low_Bound => 1,
158 Table_Initial => 20,
159 Table_Increment => 100,
160 Table_Name => "Makegpr.Temp_Files");
161 -- Table to store the path name of all the created temporary files, so that
162 -- they can be deleted at the end, or when the program is interrupted.
163
164 -------------------
165 -- Add_To_Buffer --
166 -------------------
167
168 procedure Add_To_Buffer
169 (S : String;
170 To : in out String_Access;
171 Last : in out Natural)
172 is
173 begin
174 if To = null then
175 To := new String (1 .. Initial_Buffer_Size);
176 Last := 0;
177 end if;
178
179 -- If Buffer is too small, double its size
180
181 while Last + S'Length > To'Last loop
182 declare
183 New_Buffer : constant String_Access :=
184 new String (1 .. 2 * Last);
185
186 begin
187 New_Buffer (1 .. Last) := To (1 .. Last);
188 Free (To);
189 To := New_Buffer;
190 end;
191 end loop;
192
193 To (Last + 1 .. Last + S'Length) := S;
194 Last := Last + S'Length;
195 end Add_To_Buffer;
196
197 -----------------------
198 -- Body_Suffix_Id_Of --
199 -----------------------
200
201 function Body_Suffix_Id_Of
202 (In_Tree : Project_Tree_Ref;
203 Language : String;
204 Naming : Naming_Data) return File_Name_Type
205 is
206 Language_Id : Name_Id;
207
208 begin
209 Name_Len := 0;
210 Add_Str_To_Name_Buffer (Language);
211 To_Lower (Name_Buffer (1 .. Name_Len));
212 Language_Id := Name_Find;
213
214 return
215 Body_Suffix_Id_Of
216 (In_Tree => In_Tree,
217 Language_Id => Language_Id,
218 Naming => Naming);
219 end Body_Suffix_Id_Of;
220
221 -----------------------
222 -- Body_Suffix_Id_Of --
223 -----------------------
224
225 function Body_Suffix_Id_Of
226 (In_Tree : Project_Tree_Ref;
227 Language_Id : Name_Id;
228 Naming : Naming_Data) return File_Name_Type
229 is
230 Element_Id : Array_Element_Id;
231 Element : Array_Element;
232 Suffix : File_Name_Type := No_File;
233 Lang : Language_Index;
234
235 begin
236 -- ??? This seems to be only for Ada_Only mode...
237 Element_Id := Naming.Body_Suffix;
238 while Element_Id /= No_Array_Element loop
239 Element := In_Tree.Array_Elements.Table (Element_Id);
240
241 if Element.Index = Language_Id then
242 return File_Name_Type (Element.Value.Value);
243 end if;
244
245 Element_Id := Element.Next;
246 end loop;
247
248 if Current_Mode = Multi_Language then
249 Lang := In_Tree.First_Language;
250 while Lang /= No_Language_Index loop
251 if In_Tree.Languages_Data.Table (Lang).Name = Language_Id then
252 Suffix :=
253 In_Tree.Languages_Data.Table
254 (Lang).Config.Naming_Data.Body_Suffix;
255 exit;
256 end if;
257
258 Lang := In_Tree.Languages_Data.Table (Lang).Next;
259 end loop;
260 end if;
261
262 return Suffix;
263 end Body_Suffix_Id_Of;
264
265 --------------------
266 -- Body_Suffix_Of --
267 --------------------
268
269 function Body_Suffix_Of
270 (In_Tree : Project_Tree_Ref;
271 Language : String;
272 Naming : Naming_Data) return String
273 is
274 Language_Id : Name_Id;
275 Element_Id : Array_Element_Id;
276 Element : Array_Element;
277 Suffix : File_Name_Type := No_File;
278 Lang : Language_Index;
279
280 begin
281 Name_Len := 0;
282 Add_Str_To_Name_Buffer (Language);
283 To_Lower (Name_Buffer (1 .. Name_Len));
284 Language_Id := Name_Find;
285
286 Element_Id := Naming.Body_Suffix;
287 while Element_Id /= No_Array_Element loop
288 Element := In_Tree.Array_Elements.Table (Element_Id);
289
290 if Element.Index = Language_Id then
291 return Get_Name_String (Element.Value.Value);
292 end if;
293
294 Element_Id := Element.Next;
295 end loop;
296
297 if Current_Mode = Multi_Language then
298 Lang := In_Tree.First_Language;
299 while Lang /= No_Language_Index loop
300 if In_Tree.Languages_Data.Table (Lang).Name = Language_Id then
301 Suffix :=
302 File_Name_Type
303 (In_Tree.Languages_Data.Table
304 (Lang).Config.Naming_Data.Body_Suffix);
305 exit;
306 end if;
307
308 Lang := In_Tree.Languages_Data.Table (Lang).Next;
309 end loop;
310
311 if Suffix /= No_File then
312 return Get_Name_String (Suffix);
313 end if;
314 end if;
315
316 return "";
317 end Body_Suffix_Of;
318
319 -----------------------------
320 -- Default_Ada_Body_Suffix --
321 -----------------------------
322
323 function Default_Ada_Body_Suffix return File_Name_Type is
324 begin
325 return Default_Ada_Body_Suffix_Id;
326 end Default_Ada_Body_Suffix;
327
328 -----------------------------
329 -- Default_Ada_Spec_Suffix --
330 -----------------------------
331
332 function Default_Ada_Spec_Suffix return File_Name_Type is
333 begin
334 return Default_Ada_Spec_Suffix_Id;
335 end Default_Ada_Spec_Suffix;
336
337 ---------------------------
338 -- Delete_All_Temp_Files --
339 ---------------------------
340
341 procedure Delete_All_Temp_Files is
342 Dont_Care : Boolean;
343 pragma Warnings (Off, Dont_Care);
344 begin
345 if not Debug.Debug_Flag_N then
346 for Index in 1 .. Temp_Files.Last loop
347 Delete_File
348 (Get_Name_String (Temp_Files.Table (Index)), Dont_Care);
349 end loop;
350 end if;
351 end Delete_All_Temp_Files;
352
353 ---------------------
354 -- Dependency_Name --
355 ---------------------
356
357 function Dependency_Name
358 (Source_File_Name : File_Name_Type;
359 Dependency : Dependency_File_Kind) return File_Name_Type
360 is
361 begin
362 case Dependency is
363 when None =>
364 return No_File;
365
366 when Makefile =>
367 return
368 File_Name_Type
369 (Extend_Name
370 (Source_File_Name, Makefile_Dependency_Suffix));
371
372 when ALI_File =>
373 return
374 File_Name_Type
375 (Extend_Name
376 (Source_File_Name, ALI_Dependency_Suffix));
377 end case;
378 end Dependency_Name;
379
380 ---------------------------
381 -- Display_Language_Name --
382 ---------------------------
383
384 procedure Display_Language_Name
385 (In_Tree : Project_Tree_Ref;
386 Language : Language_Index)
387 is
388 begin
389 Get_Name_String (In_Tree.Languages_Data.Table (Language).Display_Name);
390 Write_Str (Name_Buffer (1 .. Name_Len));
391 end Display_Language_Name;
392
393 ----------------
394 -- Empty_File --
395 ----------------
396
397 function Empty_File return File_Name_Type is
398 begin
399 return File_Name_Type (The_Empty_String);
400 end Empty_File;
401
402 -------------------
403 -- Empty_Project --
404 -------------------
405
406 function Empty_Project (Tree : Project_Tree_Ref) return Project_Data is
407 Value : Project_Data;
408
409 begin
410 Prj.Initialize (Tree => No_Project_Tree);
411 Value := Project_Empty;
412 Value.Naming := Tree.Private_Part.Default_Naming;
413
414 return Value;
415 end Empty_Project;
416
417 ------------------
418 -- Empty_String --
419 ------------------
420
421 function Empty_String return Name_Id is
422 begin
423 return The_Empty_String;
424 end Empty_String;
425
426 ------------
427 -- Expect --
428 ------------
429
430 procedure Expect (The_Token : Token_Type; Token_Image : String) is
431 begin
432 if Token /= The_Token then
433 Error_Msg (Token_Image & " expected", Token_Ptr);
434 end if;
435 end Expect;
436
437 -----------------
438 -- Extend_Name --
439 -----------------
440
441 function Extend_Name
442 (File : File_Name_Type;
443 With_Suffix : String) return File_Name_Type
444 is
445 Last : Positive;
446
447 begin
448 Get_Name_String (File);
449 Last := Name_Len + 1;
450
451 while Name_Len /= 0 and then Name_Buffer (Name_Len) /= '.' loop
452 Name_Len := Name_Len - 1;
453 end loop;
454
455 if Name_Len <= 1 then
456 Name_Len := Last;
457 end if;
458
459 for J in With_Suffix'Range loop
460 Name_Buffer (Name_Len) := With_Suffix (J);
461 Name_Len := Name_Len + 1;
462 end loop;
463
464 Name_Len := Name_Len - 1;
465 return Name_Find;
466
467 end Extend_Name;
468
469 --------------------------------
470 -- For_Every_Project_Imported --
471 --------------------------------
472
473 procedure For_Every_Project_Imported
474 (By : Project_Id;
475 In_Tree : Project_Tree_Ref;
476 With_State : in out State)
477 is
478
479 procedure Recursive_Check (Project : Project_Id);
480 -- Check if a project has already been seen. If not seen, mark it as
481 -- Seen, Call Action, and check all its imported projects.
482
483 ---------------------
484 -- Recursive_Check --
485 ---------------------
486
487 procedure Recursive_Check (Project : Project_Id) is
488 List : Project_List;
489 begin
490 if not In_Tree.Projects.Table (Project).Seen then
491 In_Tree.Projects.Table (Project).Seen := True;
492 Action (Project, With_State);
493
494 List := In_Tree.Projects.Table (Project).Imported_Projects;
495 while List /= Empty_Project_List loop
496 Recursive_Check (In_Tree.Project_Lists.Table (List).Project);
497 List := In_Tree.Project_Lists.Table (List).Next;
498 end loop;
499 end if;
500 end Recursive_Check;
501
502 -- Start of processing for For_Every_Project_Imported
503
504 begin
505 for Project in Project_Table.First ..
506 Project_Table.Last (In_Tree.Projects)
507 loop
508 In_Tree.Projects.Table (Project).Seen := False;
509 end loop;
510
511 Recursive_Check (Project => By);
512 end For_Every_Project_Imported;
513
514 --------------
515 -- Get_Mode --
516 --------------
517
518 function Get_Mode return Mode is
519 begin
520 return Current_Mode;
521 end Get_Mode;
522
523 ----------
524 -- Hash --
525 ----------
526
527 function Hash is new System.HTable.Hash (Header_Num => Header_Num);
528 -- Used in implementation of other functions Hash below
529
530 function Hash (Name : File_Name_Type) return Header_Num is
531 begin
532 return Hash (Get_Name_String (Name));
533 end Hash;
534
535 function Hash (Name : Name_Id) return Header_Num is
536 begin
537 return Hash (Get_Name_String (Name));
538 end Hash;
539
540 function Hash (Name : Path_Name_Type) return Header_Num is
541 begin
542 return Hash (Get_Name_String (Name));
543 end Hash;
544
545 function Hash (Project : Project_Id) return Header_Num is
546 begin
547 return Header_Num (Project mod Max_Header_Num);
548 end Hash;
549
550 -----------
551 -- Image --
552 -----------
553
554 function Image (Casing : Casing_Type) return String is
555 begin
556 return The_Casing_Images (Casing).all;
557 end Image;
558
559 ----------------------
560 -- In_Configuration --
561 ----------------------
562
563 function In_Configuration return Boolean is
564 begin
565 return Configuration_Mode;
566 end In_Configuration;
567
568 ----------------
569 -- Initialize --
570 ----------------
571
572 procedure Initialize (Tree : Project_Tree_Ref) is
573 begin
574 if not Initialized then
575 Initialized := True;
576 Uintp.Initialize;
577 Name_Len := 0;
578 The_Empty_String := Name_Find;
579 Empty_Name := The_Empty_String;
580 Empty_File_Name := File_Name_Type (The_Empty_String);
581 Name_Len := 4;
582 Name_Buffer (1 .. 4) := ".ads";
583 Default_Ada_Spec_Suffix_Id := Name_Find;
584 Name_Len := 4;
585 Name_Buffer (1 .. 4) := ".adb";
586 Default_Ada_Body_Suffix_Id := Name_Find;
587 Name_Len := 1;
588 Name_Buffer (1) := '/';
589 Slash_Id := Name_Find;
590
591 Prj.Env.Initialize;
592 Prj.Attr.Initialize;
593 Set_Name_Table_Byte (Name_Project, Token_Type'Pos (Tok_Project));
594 Set_Name_Table_Byte (Name_Extends, Token_Type'Pos (Tok_Extends));
595 Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External));
596 end if;
597
598 if Tree /= No_Project_Tree then
599 Reset (Tree);
600 end if;
601 end Initialize;
602
603 -------------------
604 -- Is_A_Language --
605 -------------------
606
607 function Is_A_Language
608 (Tree : Project_Tree_Ref;
609 Data : Project_Data;
610 Language_Name : Name_Id) return Boolean
611 is
612 begin
613 if Get_Mode = Ada_Only then
614 declare
615 List : Name_List_Index := Data.Languages;
616 begin
617 while List /= No_Name_List loop
618 if Tree.Name_Lists.Table (List).Name = Language_Name then
619 return True;
620 else
621 List := Tree.Name_Lists.Table (List).Next;
622 end if;
623 end loop;
624 end;
625
626 else
627 declare
628 Lang_Ind : Language_Index := Data.First_Language_Processing;
629 Lang_Data : Language_Data;
630
631 begin
632 while Lang_Ind /= No_Language_Index loop
633 Lang_Data := Tree.Languages_Data.Table (Lang_Ind);
634
635 if Lang_Data.Name = Language_Name then
636 return True;
637 end if;
638
639 Lang_Ind := Lang_Data.Next;
640 end loop;
641 end;
642 end if;
643
644 return False;
645 end Is_A_Language;
646
647 ------------------
648 -- Is_Extending --
649 ------------------
650
651 function Is_Extending
652 (Extending : Project_Id;
653 Extended : Project_Id;
654 In_Tree : Project_Tree_Ref) return Boolean
655 is
656 Proj : Project_Id;
657
658 begin
659 Proj := Extending;
660 while Proj /= No_Project loop
661 if Proj = Extended then
662 return True;
663 end if;
664
665 Proj := In_Tree.Projects.Table (Proj).Extends;
666 end loop;
667
668 return False;
669 end Is_Extending;
670
671 -----------------------
672 -- Objects_Exist_For --
673 -----------------------
674
675 function Objects_Exist_For
676 (Language : String;
677 In_Tree : Project_Tree_Ref) return Boolean
678 is
679 Language_Id : Name_Id;
680 Lang : Language_Index;
681
682 begin
683 if Current_Mode = Multi_Language then
684 Name_Len := 0;
685 Add_Str_To_Name_Buffer (Language);
686 To_Lower (Name_Buffer (1 .. Name_Len));
687 Language_Id := Name_Find;
688
689 Lang := In_Tree.First_Language;
690 while Lang /= No_Language_Index loop
691 if In_Tree.Languages_Data.Table (Lang).Name = Language_Id then
692 return
693 In_Tree.Languages_Data.Table
694 (Lang).Config.Object_Generated;
695 end if;
696
697 Lang := In_Tree.Languages_Data.Table (Lang).Next;
698 end loop;
699 end if;
700
701 return True;
702 end Objects_Exist_For;
703
704 -----------------
705 -- Object_Name --
706 -----------------
707
708 function Object_Name
709 (Source_File_Name : File_Name_Type)
710 return File_Name_Type
711 is
712 begin
713 return Extend_Name (Source_File_Name, Object_Suffix);
714 end Object_Name;
715
716 ----------------------
717 -- Record_Temp_File --
718 ----------------------
719
720 procedure Record_Temp_File (Path : Path_Name_Type) is
721 begin
722 Temp_Files.Increment_Last;
723 Temp_Files.Table (Temp_Files.Last) := Path;
724 end Record_Temp_File;
725
726 ------------------------------------
727 -- Register_Default_Naming_Scheme --
728 ------------------------------------
729
730 procedure Register_Default_Naming_Scheme
731 (Language : Name_Id;
732 Default_Spec_Suffix : File_Name_Type;
733 Default_Body_Suffix : File_Name_Type;
734 In_Tree : Project_Tree_Ref)
735 is
736 Lang : Name_Id;
737 Suffix : Array_Element_Id;
738 Found : Boolean := False;
739 Element : Array_Element;
740
741 begin
742 -- Get the language name in small letters
743
744 Get_Name_String (Language);
745 Name_Buffer (1 .. Name_Len) := To_Lower (Name_Buffer (1 .. Name_Len));
746 Lang := Name_Find;
747
748 -- Look for an element of the spec suffix array indexed by the language
749 -- name. If one is found, put the default value.
750
751 Suffix := In_Tree.Private_Part.Default_Naming.Spec_Suffix;
752 Found := False;
753 while Suffix /= No_Array_Element and then not Found loop
754 Element := In_Tree.Array_Elements.Table (Suffix);
755
756 if Element.Index = Lang then
757 Found := True;
758 Element.Value.Value := Name_Id (Default_Spec_Suffix);
759 In_Tree.Array_Elements.Table (Suffix) := Element;
760
761 else
762 Suffix := Element.Next;
763 end if;
764 end loop;
765
766 -- If none can be found, create a new one
767
768 if not Found then
769 Element :=
770 (Index => Lang,
771 Src_Index => 0,
772 Index_Case_Sensitive => False,
773 Value => (Project => No_Project,
774 Kind => Single,
775 Location => No_Location,
776 Default => False,
777 Value => Name_Id (Default_Spec_Suffix),
778 Index => 0),
779 Next => In_Tree.Private_Part.Default_Naming.Spec_Suffix);
780 Array_Element_Table.Increment_Last (In_Tree.Array_Elements);
781 In_Tree.Array_Elements.Table
782 (Array_Element_Table.Last (In_Tree.Array_Elements)) :=
783 Element;
784 In_Tree.Private_Part.Default_Naming.Spec_Suffix :=
785 Array_Element_Table.Last (In_Tree.Array_Elements);
786 end if;
787
788 -- Look for an element of the body suffix array indexed by the language
789 -- name. If one is found, put the default value.
790
791 Suffix := In_Tree.Private_Part.Default_Naming.Body_Suffix;
792 Found := False;
793 while Suffix /= No_Array_Element and then not Found loop
794 Element := In_Tree.Array_Elements.Table (Suffix);
795
796 if Element.Index = Lang then
797 Found := True;
798 Element.Value.Value := Name_Id (Default_Body_Suffix);
799 In_Tree.Array_Elements.Table (Suffix) := Element;
800
801 else
802 Suffix := Element.Next;
803 end if;
804 end loop;
805
806 -- If none can be found, create a new one
807
808 if not Found then
809 Element :=
810 (Index => Lang,
811 Src_Index => 0,
812 Index_Case_Sensitive => False,
813 Value => (Project => No_Project,
814 Kind => Single,
815 Location => No_Location,
816 Default => False,
817 Value => Name_Id (Default_Body_Suffix),
818 Index => 0),
819 Next => In_Tree.Private_Part.Default_Naming.Body_Suffix);
820 Array_Element_Table.Increment_Last
821 (In_Tree.Array_Elements);
822 In_Tree.Array_Elements.Table
823 (Array_Element_Table.Last (In_Tree.Array_Elements))
824 := Element;
825 In_Tree.Private_Part.Default_Naming.Body_Suffix :=
826 Array_Element_Table.Last (In_Tree.Array_Elements);
827 end if;
828 end Register_Default_Naming_Scheme;
829
830 ----------
831 -- Free --
832 ----------
833
834 procedure Free (Tree : in out Project_Tree_Ref) is
835 procedure Unchecked_Free is new Ada.Unchecked_Deallocation
836 (Project_Tree_Data, Project_Tree_Ref);
837 begin
838 if Tree /= null then
839 Language_Data_Table.Free (Tree.Languages_Data);
840 Name_List_Table.Free (Tree.Name_Lists);
841 String_Element_Table.Free (Tree.String_Elements);
842 Variable_Element_Table.Free (Tree.Variable_Elements);
843 Array_Element_Table.Free (Tree.Array_Elements);
844 Array_Table.Free (Tree.Arrays);
845 Package_Table.Free (Tree.Packages);
846 Project_List_Table.Free (Tree.Project_Lists);
847 Project_Table.Free (Tree.Projects);
848 Source_Data_Table.Free (Tree.Sources);
849 Alternate_Language_Table.Free (Tree.Alt_Langs);
850 Unit_Table.Free (Tree.Units);
851 Units_Htable.Reset (Tree.Units_HT);
852 Files_Htable.Reset (Tree.Files_HT);
853 Source_Paths_Htable.Reset (Tree.Source_Paths_HT);
854 Unit_Sources_Htable.Reset (Tree.Unit_Sources_HT);
855
856 -- Private part
857
858 Naming_Table.Free (Tree.Private_Part.Namings);
859 Path_File_Table.Free (Tree.Private_Part.Path_Files);
860 Source_Path_Table.Free (Tree.Private_Part.Source_Paths);
861 Object_Path_Table.Free (Tree.Private_Part.Object_Paths);
862
863 -- Naming data (nothing to free ?)
864 null;
865
866 Unchecked_Free (Tree);
867 end if;
868 end Free;
869
870 -----------
871 -- Reset --
872 -----------
873
874 procedure Reset (Tree : Project_Tree_Ref) is
875 begin
876 Prj.Env.Initialize;
877
878 -- Visible tables
879
880 Language_Data_Table.Init (Tree.Languages_Data);
881 Name_List_Table.Init (Tree.Name_Lists);
882 String_Element_Table.Init (Tree.String_Elements);
883 Variable_Element_Table.Init (Tree.Variable_Elements);
884 Array_Element_Table.Init (Tree.Array_Elements);
885 Array_Table.Init (Tree.Arrays);
886 Package_Table.Init (Tree.Packages);
887 Project_List_Table.Init (Tree.Project_Lists);
888 Project_Table.Init (Tree.Projects);
889 Source_Data_Table.Init (Tree.Sources);
890 Alternate_Language_Table.Init (Tree.Alt_Langs);
891 Unit_Table.Init (Tree.Units);
892 Units_Htable.Reset (Tree.Units_HT);
893 Files_Htable.Reset (Tree.Files_HT);
894 Source_Paths_Htable.Reset (Tree.Source_Paths_HT);
895 Unit_Sources_Htable.Reset (Tree.Unit_Sources_HT);
896
897 -- Private part table
898
899 Naming_Table.Init (Tree.Private_Part.Namings);
900 Naming_Table.Increment_Last (Tree.Private_Part.Namings);
901 Tree.Private_Part.Namings.Table
902 (Naming_Table.Last (Tree.Private_Part.Namings)) := Std_Naming_Data;
903 Path_File_Table.Init (Tree.Private_Part.Path_Files);
904 Source_Path_Table.Init (Tree.Private_Part.Source_Paths);
905 Object_Path_Table.Init (Tree.Private_Part.Object_Paths);
906 Tree.Private_Part.Default_Naming := Std_Naming_Data;
907
908 if Current_Mode = Ada_Only then
909 Register_Default_Naming_Scheme
910 (Language => Name_Ada,
911 Default_Spec_Suffix => Default_Ada_Spec_Suffix,
912 Default_Body_Suffix => Default_Ada_Body_Suffix,
913 In_Tree => Tree);
914 Tree.Private_Part.Default_Naming.Separate_Suffix :=
915 Default_Ada_Body_Suffix;
916 end if;
917 end Reset;
918
919 ------------------------
920 -- Same_Naming_Scheme --
921 ------------------------
922
923 function Same_Naming_Scheme
924 (Left, Right : Naming_Data) return Boolean
925 is
926 begin
927 return Left.Dot_Replacement = Right.Dot_Replacement
928 and then Left.Casing = Right.Casing
929 and then Left.Separate_Suffix = Right.Separate_Suffix;
930 end Same_Naming_Scheme;
931
932 ---------------------
933 -- Set_Body_Suffix --
934 ---------------------
935
936 procedure Set_Body_Suffix
937 (In_Tree : Project_Tree_Ref;
938 Language : String;
939 Naming : in out Naming_Data;
940 Suffix : File_Name_Type)
941 is
942 Language_Id : Name_Id;
943 Element : Array_Element;
944
945 begin
946 Name_Len := 0;
947 Add_Str_To_Name_Buffer (Language);
948 To_Lower (Name_Buffer (1 .. Name_Len));
949 Language_Id := Name_Find;
950
951 Element :=
952 (Index => Language_Id,
953 Src_Index => 0,
954 Index_Case_Sensitive => False,
955 Value =>
956 (Kind => Single,
957 Project => No_Project,
958 Location => No_Location,
959 Default => False,
960 Value => Name_Id (Suffix),
961 Index => 0),
962 Next => Naming.Body_Suffix);
963
964 Array_Element_Table.Increment_Last (In_Tree.Array_Elements);
965 Naming.Body_Suffix :=
966 Array_Element_Table.Last (In_Tree.Array_Elements);
967 In_Tree.Array_Elements.Table (Naming.Body_Suffix) := Element;
968 end Set_Body_Suffix;
969
970 --------------------------
971 -- Set_In_Configuration --
972 --------------------------
973
974 procedure Set_In_Configuration (Value : Boolean) is
975 begin
976 Configuration_Mode := Value;
977 end Set_In_Configuration;
978
979 --------------
980 -- Set_Mode --
981 --------------
982
983 procedure Set_Mode (New_Mode : Mode) is
984 begin
985 Current_Mode := New_Mode;
986 case New_Mode is
987 when Ada_Only =>
988 Default_Language_Is_Ada := True;
989 Must_Check_Configuration := False;
990 when Multi_Language =>
991 Default_Language_Is_Ada := False;
992 Must_Check_Configuration := True;
993 end case;
994 end Set_Mode;
995
996 ---------------------
997 -- Set_Spec_Suffix --
998 ---------------------
999
1000 procedure Set_Spec_Suffix
1001 (In_Tree : Project_Tree_Ref;
1002 Language : String;
1003 Naming : in out Naming_Data;
1004 Suffix : File_Name_Type)
1005 is
1006 Language_Id : Name_Id;
1007 Element : Array_Element;
1008
1009 begin
1010 Name_Len := 0;
1011 Add_Str_To_Name_Buffer (Language);
1012 To_Lower (Name_Buffer (1 .. Name_Len));
1013 Language_Id := Name_Find;
1014
1015 Element :=
1016 (Index => Language_Id,
1017 Src_Index => 0,
1018 Index_Case_Sensitive => False,
1019 Value =>
1020 (Kind => Single,
1021 Project => No_Project,
1022 Location => No_Location,
1023 Default => False,
1024 Value => Name_Id (Suffix),
1025 Index => 0),
1026 Next => Naming.Spec_Suffix);
1027
1028 Array_Element_Table.Increment_Last (In_Tree.Array_Elements);
1029 Naming.Spec_Suffix :=
1030 Array_Element_Table.Last (In_Tree.Array_Elements);
1031 In_Tree.Array_Elements.Table (Naming.Spec_Suffix) := Element;
1032 end Set_Spec_Suffix;
1033
1034 -----------
1035 -- Slash --
1036 -----------
1037
1038 function Slash return Path_Name_Type is
1039 begin
1040 return Slash_Id;
1041 end Slash;
1042
1043 -----------------------
1044 -- Spec_Suffix_Id_Of --
1045 -----------------------
1046
1047 function Spec_Suffix_Id_Of
1048 (In_Tree : Project_Tree_Ref;
1049 Language : String;
1050 Naming : Naming_Data) return File_Name_Type
1051 is
1052 Language_Id : Name_Id;
1053
1054 begin
1055 Name_Len := 0;
1056 Add_Str_To_Name_Buffer (Language);
1057 To_Lower (Name_Buffer (1 .. Name_Len));
1058 Language_Id := Name_Find;
1059
1060 return
1061 Spec_Suffix_Id_Of
1062 (In_Tree => In_Tree,
1063 Language_Id => Language_Id,
1064 Naming => Naming);
1065 end Spec_Suffix_Id_Of;
1066
1067 -----------------------
1068 -- Spec_Suffix_Id_Of --
1069 -----------------------
1070
1071 function Spec_Suffix_Id_Of
1072 (In_Tree : Project_Tree_Ref;
1073 Language_Id : Name_Id;
1074 Naming : Naming_Data) return File_Name_Type
1075 is
1076 Element_Id : Array_Element_Id;
1077 Element : Array_Element;
1078 Suffix : File_Name_Type := No_File;
1079 Lang : Language_Index;
1080
1081 begin
1082 Element_Id := Naming.Spec_Suffix;
1083 while Element_Id /= No_Array_Element loop
1084 Element := In_Tree.Array_Elements.Table (Element_Id);
1085
1086 if Element.Index = Language_Id then
1087 return File_Name_Type (Element.Value.Value);
1088 end if;
1089
1090 Element_Id := Element.Next;
1091 end loop;
1092
1093 if Current_Mode = Multi_Language then
1094 Lang := In_Tree.First_Language;
1095 while Lang /= No_Language_Index loop
1096 if In_Tree.Languages_Data.Table (Lang).Name = Language_Id then
1097 Suffix :=
1098 In_Tree.Languages_Data.Table
1099 (Lang).Config.Naming_Data.Spec_Suffix;
1100 exit;
1101 end if;
1102
1103 Lang := In_Tree.Languages_Data.Table (Lang).Next;
1104 end loop;
1105 end if;
1106
1107 return Suffix;
1108 end Spec_Suffix_Id_Of;
1109
1110 --------------------
1111 -- Spec_Suffix_Of --
1112 --------------------
1113
1114 function Spec_Suffix_Of
1115 (In_Tree : Project_Tree_Ref;
1116 Language : String;
1117 Naming : Naming_Data) return String
1118 is
1119 Language_Id : Name_Id;
1120 Element_Id : Array_Element_Id;
1121 Element : Array_Element;
1122 Suffix : File_Name_Type := No_File;
1123 Lang : Language_Index;
1124
1125 begin
1126 Name_Len := 0;
1127 Add_Str_To_Name_Buffer (Language);
1128 To_Lower (Name_Buffer (1 .. Name_Len));
1129 Language_Id := Name_Find;
1130
1131 Element_Id := Naming.Spec_Suffix;
1132 while Element_Id /= No_Array_Element loop
1133 Element := In_Tree.Array_Elements.Table (Element_Id);
1134
1135 if Element.Index = Language_Id then
1136 return Get_Name_String (Element.Value.Value);
1137 end if;
1138
1139 Element_Id := Element.Next;
1140 end loop;
1141
1142 if Current_Mode = Multi_Language then
1143 Lang := In_Tree.First_Language;
1144 while Lang /= No_Language_Index loop
1145 if In_Tree.Languages_Data.Table (Lang).Name = Language_Id then
1146 Suffix :=
1147 File_Name_Type
1148 (In_Tree.Languages_Data.Table
1149 (Lang).Config.Naming_Data.Spec_Suffix);
1150 exit;
1151 end if;
1152
1153 Lang := In_Tree.Languages_Data.Table (Lang).Next;
1154 end loop;
1155
1156 if Suffix /= No_File then
1157 return Get_Name_String (Suffix);
1158 end if;
1159 end if;
1160
1161 return "";
1162 end Spec_Suffix_Of;
1163
1164 --------------------------
1165 -- Standard_Naming_Data --
1166 --------------------------
1167
1168 function Standard_Naming_Data
1169 (Tree : Project_Tree_Ref := No_Project_Tree) return Naming_Data
1170 is
1171 begin
1172 if Tree = No_Project_Tree then
1173 Prj.Initialize (Tree => No_Project_Tree);
1174 return Std_Naming_Data;
1175 else
1176 return Tree.Private_Part.Default_Naming;
1177 end if;
1178 end Standard_Naming_Data;
1179
1180 -------------------
1181 -- Switches_Name --
1182 -------------------
1183
1184 function Switches_Name
1185 (Source_File_Name : File_Name_Type) return File_Name_Type
1186 is
1187 begin
1188 return Extend_Name (Source_File_Name, Switches_Dependency_Suffix);
1189 end Switches_Name;
1190
1191 -----------
1192 -- Value --
1193 -----------
1194
1195 function Value (Image : String) return Casing_Type is
1196 begin
1197 for Casing in The_Casing_Images'Range loop
1198 if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then
1199 return Casing;
1200 end if;
1201 end loop;
1202
1203 raise Constraint_Error;
1204 end Value;
1205
1206 begin
1207 -- Make sure that the standard config and user project file extensions are
1208 -- compatible with canonical case file naming.
1209
1210 Canonical_Case_File_Name (Config_Project_File_Extension);
1211 Canonical_Case_File_Name (Project_File_Extension);
1212 end Prj;