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