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