?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Merge from mainline (160224:163495).
[official-gcc/graphite-test-results.git] / gcc / ada / prj-conf.adb
blob7ffa8d52b945f43964e8778e14746be38fb2b3c0
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- P R J . C O N F --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2006-2010, 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 Hostparm;
27 with Makeutl; use Makeutl;
28 with MLib.Tgt;
29 with Opt; use Opt;
30 with Output; use Output;
31 with Prj.Env;
32 with Prj.Err;
33 with Prj.Part;
34 with Prj.PP;
35 with Prj.Proc; use Prj.Proc;
36 with Prj.Tree; use Prj.Tree;
37 with Prj.Util; use Prj.Util;
38 with Prj; use Prj;
39 with Snames; use Snames;
40
41 with Ada.Directories; use Ada.Directories;
42
43 with GNAT.Case_Util; use GNAT.Case_Util;
44 with GNAT.HTable; use GNAT.HTable;
45
46 package body Prj.Conf is
47
48 Auto_Cgpr : constant String := "auto.cgpr";
49
50 Default_Name : constant String := "default.cgpr";
51 -- Default configuration file that will be used if found
52
53 Config_Project_Env_Var : constant String := "GPR_CONFIG";
54 -- Name of the environment variable that provides the name of the
55 -- configuration file to use.
56
57 Gprconfig_Name : constant String := "gprconfig";
58
59 package RTS_Languages is new GNAT.HTable.Simple_HTable
60 (Header_Num => Prj.Header_Num,
61 Element => Name_Id,
62 No_Element => No_Name,
63 Key => Name_Id,
64 Hash => Prj.Hash,
65 Equal => "=");
66 -- Stores the runtime names for the various languages. This is in general
67 -- set from a --RTS command line option.
68
69 procedure Add_Attributes
70 (Project_Tree : Project_Tree_Ref;
71 Conf_Decl : Declarations;
72 User_Decl : in out Declarations);
73 -- Process the attributes in the config declarations.
74 -- For single string values, if the attribute is not declared in the user
75 -- declarations, declare it with the value in the config declarations.
76 -- For string list values, prepend the value in the user declarations with
77 -- the value in the config declarations.
78
79 function Locate_Config_File (Name : String) return String_Access;
80 -- Search for Name in the config files directory. Return full path if
81 -- found, or null otherwise
82
83 function Check_Target
84 (Config_File : Prj.Project_Id;
85 Autoconf_Specified : Boolean;
86 Project_Tree : Prj.Project_Tree_Ref;
87 Target : String := "") return Boolean;
88 -- Check that the config file's target matches Target.
89 -- Target should be set to the empty string when the user did not specify
90 -- a target. If the target in the configuration file is invalid, this
91 -- function will raise Invalid_Config with an appropriate message.
92 -- Autoconf_Specified should be set to True if the user has used --autoconf
93
94 --------------------
95 -- Add_Attributes --
96 --------------------
97
98 procedure Add_Attributes
99 (Project_Tree : Project_Tree_Ref;
100 Conf_Decl : Declarations;
101 User_Decl : in out Declarations)
102 is
103 Conf_Attr_Id : Variable_Id;
104 Conf_Attr : Variable;
105 Conf_Array_Id : Array_Id;
106 Conf_Array : Array_Data;
107 Conf_Array_Elem_Id : Array_Element_Id;
108 Conf_Array_Elem : Array_Element;
109 Conf_List : String_List_Id;
110 Conf_List_Elem : String_Element;
111
112 User_Attr_Id : Variable_Id;
113 User_Attr : Variable;
114 User_Array_Id : Array_Id;
115 User_Array : Array_Data;
116 User_Array_Elem_Id : Array_Element_Id;
117 User_Array_Elem : Array_Element;
118
119 begin
120 Conf_Attr_Id := Conf_Decl.Attributes;
121 User_Attr_Id := User_Decl.Attributes;
122 while Conf_Attr_Id /= No_Variable loop
123 Conf_Attr :=
124 Project_Tree.Variable_Elements.Table (Conf_Attr_Id);
125 User_Attr :=
126 Project_Tree.Variable_Elements.Table (User_Attr_Id);
127
128 if not Conf_Attr.Value.Default then
129 if User_Attr.Value.Default then
130
131 -- No attribute declared in user project file: just copy the
132 -- value of the configuration attribute.
133
134 User_Attr.Value := Conf_Attr.Value;
135 Project_Tree.Variable_Elements.Table (User_Attr_Id) :=
136 User_Attr;
137
138 elsif User_Attr.Value.Kind = List
139 and then Conf_Attr.Value.Values /= Nil_String
140 then
141 -- List attribute declared in both the user project and the
142 -- configuration project: prepend the user list with the
143 -- configuration list.
144
145 declare
146 Conf_List : String_List_Id := Conf_Attr.Value.Values;
147 Conf_Elem : String_Element;
148 User_List : constant String_List_Id :=
149 User_Attr.Value.Values;
150 New_List : String_List_Id;
151 New_Elem : String_Element;
152
153 begin
154 -- Create new list
155
156 String_Element_Table.Increment_Last
157 (Project_Tree.String_Elements);
158 New_List := String_Element_Table.Last
159 (Project_Tree.String_Elements);
160
161 -- Value of attribute is new list
162
163 User_Attr.Value.Values := New_List;
164 Project_Tree.Variable_Elements.Table (User_Attr_Id) :=
165 User_Attr;
166
167 loop
168
169 -- Get each element of configuration list
170
171 Conf_Elem :=
172 Project_Tree.String_Elements.Table (Conf_List);
173 New_Elem := Conf_Elem;
174 Conf_List := Conf_Elem.Next;
175
176 if Conf_List = Nil_String then
177
178 -- If it is the last element in the list, connect to
179 -- first element of user list, and we are done.
180
181 New_Elem.Next := User_List;
182 Project_Tree.String_Elements.Table
183 (New_List) := New_Elem;
184 exit;
185
186 else
187 -- If it is not the last element in the list, add to
188 -- new list.
189
190 String_Element_Table.Increment_Last
191 (Project_Tree.String_Elements);
192 New_Elem.Next :=
193 String_Element_Table.Last
194 (Project_Tree.String_Elements);
195 Project_Tree.String_Elements.Table
196 (New_List) := New_Elem;
197 New_List := New_Elem.Next;
198 end if;
199 end loop;
200 end;
201 end if;
202 end if;
203
204 Conf_Attr_Id := Conf_Attr.Next;
205 User_Attr_Id := User_Attr.Next;
206 end loop;
207
208 Conf_Array_Id := Conf_Decl.Arrays;
209 while Conf_Array_Id /= No_Array loop
210 Conf_Array := Project_Tree.Arrays.Table (Conf_Array_Id);
211
212 User_Array_Id := User_Decl.Arrays;
213 while User_Array_Id /= No_Array loop
214 User_Array := Project_Tree.Arrays.Table (User_Array_Id);
215 exit when User_Array.Name = Conf_Array.Name;
216 User_Array_Id := User_Array.Next;
217 end loop;
218
219 -- If this associative array does not exist in the user project file,
220 -- do a shallow copy of the full associative array.
221
222 if User_Array_Id = No_Array then
223 Array_Table.Increment_Last (Project_Tree.Arrays);
224 User_Array := Conf_Array;
225 User_Array.Next := User_Decl.Arrays;
226 User_Decl.Arrays := Array_Table.Last (Project_Tree.Arrays);
227 Project_Tree.Arrays.Table (User_Decl.Arrays) := User_Array;
228
229 else
230 -- Otherwise, check each array element
231
232 Conf_Array_Elem_Id := Conf_Array.Value;
233 while Conf_Array_Elem_Id /= No_Array_Element loop
234 Conf_Array_Elem :=
235 Project_Tree.Array_Elements.Table (Conf_Array_Elem_Id);
236
237 User_Array_Elem_Id := User_Array.Value;
238 while User_Array_Elem_Id /= No_Array_Element loop
239 User_Array_Elem :=
240 Project_Tree.Array_Elements.Table (User_Array_Elem_Id);
241 exit when User_Array_Elem.Index = Conf_Array_Elem.Index;
242 User_Array_Elem_Id := User_Array_Elem.Next;
243 end loop;
244
245 -- If the array element does not exist in the user array,
246 -- insert a shallow copy of the conf array element in the
247 -- user array.
248
249 if User_Array_Elem_Id = No_Array_Element then
250 Array_Element_Table.Increment_Last
251 (Project_Tree.Array_Elements);
252 User_Array_Elem := Conf_Array_Elem;
253 User_Array_Elem.Next := User_Array.Value;
254 User_Array.Value :=
255 Array_Element_Table.Last (Project_Tree.Array_Elements);
256 Project_Tree.Array_Elements.Table (User_Array.Value) :=
257 User_Array_Elem;
258 Project_Tree.Arrays.Table (User_Array_Id) := User_Array;
259
260 -- Otherwise, if the value is a string list, prepend the
261 -- user array element with the conf array element value.
262
263 elsif Conf_Array_Elem.Value.Kind = List then
264 Conf_List := Conf_Array_Elem.Value.Values;
265
266 if Conf_List /= Nil_String then
267 declare
268 Link : constant String_List_Id :=
269 User_Array_Elem.Value.Values;
270 Previous : String_List_Id := Nil_String;
271 Next : String_List_Id;
272
273 begin
274 loop
275 Conf_List_Elem :=
276 Project_Tree.String_Elements.Table
277 (Conf_List);
278 String_Element_Table.Increment_Last
279 (Project_Tree.String_Elements);
280 Next :=
281 String_Element_Table.Last
282 (Project_Tree.String_Elements);
283 Project_Tree.String_Elements.Table (Next) :=
284 Conf_List_Elem;
285
286 if Previous = Nil_String then
287 User_Array_Elem.Value.Values := Next;
288 Project_Tree.Array_Elements.Table
289 (User_Array_Elem_Id) := User_Array_Elem;
290
291 else
292 Project_Tree.String_Elements.Table
293 (Previous).Next := Next;
294 end if;
295
296 Previous := Next;
297
298 Conf_List := Conf_List_Elem.Next;
299
300 if Conf_List = Nil_String then
301 Project_Tree.String_Elements.Table
302 (Previous).Next := Link;
303 exit;
304 end if;
305 end loop;
306 end;
307 end if;
308 end if;
309
310 Conf_Array_Elem_Id := Conf_Array_Elem.Next;
311 end loop;
312 end if;
313
314 Conf_Array_Id := Conf_Array.Next;
315 end loop;
316 end Add_Attributes;
317
318 ------------------------
319 -- Locate_Config_File --
320 ------------------------
321
322 function Locate_Config_File (Name : String) return String_Access is
323 Prefix_Path : constant String := Executable_Prefix_Path;
324 begin
325 if Prefix_Path'Length /= 0 then
326 return Locate_Regular_File
327 (Name,
328 "." & Path_Separator &
329 Prefix_Path & "share" & Directory_Separator & "gpr");
330 else
331 return Locate_Regular_File (Name, ".");
332 end if;
333 end Locate_Config_File;
334
335 ------------------
336 -- Check_Target --
337 ------------------
338
339 function Check_Target
340 (Config_File : Project_Id;
341 Autoconf_Specified : Boolean;
342 Project_Tree : Prj.Project_Tree_Ref;
343 Target : String := "") return Boolean
344 is
345 Variable : constant Variable_Value :=
346 Value_Of
347 (Name_Target, Config_File.Decl.Attributes, Project_Tree);
348 Tgt_Name : Name_Id := No_Name;
349 OK : Boolean;
350
351 begin
352 if Variable /= Nil_Variable_Value and then not Variable.Default then
353 Tgt_Name := Variable.Value;
354 end if;
355
356 if Target = "" then
357 OK := not Autoconf_Specified or else Tgt_Name = No_Name;
358 else
359 OK := Tgt_Name /= No_Name
360 and then Target = Get_Name_String (Tgt_Name);
361 end if;
362
363 if not OK then
364 if Autoconf_Specified then
365 if Verbose_Mode then
366 Write_Line ("inconsistent targets, performing autoconf");
367 end if;
368
369 return False;
370
371 else
372 if Tgt_Name /= No_Name then
373 raise Invalid_Config
374 with "invalid target name """
375 & Get_Name_String (Tgt_Name) & """ in configuration";
376
377 else
378 raise Invalid_Config
379 with "no target specified in configuration file";
380 end if;
381 end if;
382 end if;
383
384 return True;
385 end Check_Target;
386
387 --------------------------------------
388 -- Get_Or_Create_Configuration_File --
389 --------------------------------------
390
391 procedure Get_Or_Create_Configuration_File
392 (Project : Project_Id;
393 Project_Tree : Project_Tree_Ref;
394 Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
395 Allow_Automatic_Generation : Boolean;
396 Config_File_Name : String := "";
397 Autoconf_Specified : Boolean;
398 Target_Name : String := "";
399 Normalized_Hostname : String;
400 Packages_To_Check : String_List_Access := null;
401 Config : out Prj.Project_Id;
402 Config_File_Path : out String_Access;
403 Automatically_Generated : out Boolean;
404 Flags : Processing_Flags;
405 On_Load_Config : Config_File_Hook := null)
406 is
407 function Default_File_Name return String;
408 -- Return the name of the default config file that should be tested
409
410 procedure Do_Autoconf;
411 -- Generate a new config file through gprconfig.
412 -- In case of error, this raises the Invalid_Config exception with an
413 -- appropriate message
414
415 function Get_Config_Switches return Argument_List_Access;
416 -- Return the --config switches to use for gprconfig
417
418 function Might_Have_Sources (Project : Project_Id) return Boolean;
419 -- True if the specified project might have sources (ie the user has not
420 -- explicitly specified it. We haven't checked the file system, nor do
421 -- we need to at this stage.
422
423 -----------------------
424 -- Default_File_Name --
425 -----------------------
426
427 function Default_File_Name return String is
428 Ada_RTS : constant String := Runtime_Name_For (Name_Ada);
429 Tmp : String_Access;
430
431 begin
432 if Target_Name /= "" then
433 if Ada_RTS /= "" then
434 return Target_Name & '-' & Ada_RTS
435 & Config_Project_File_Extension;
436 else
437 return Target_Name & Config_Project_File_Extension;
438 end if;
439
440 elsif Ada_RTS /= "" then
441 return Ada_RTS & Config_Project_File_Extension;
442
443 else
444 Tmp := Getenv (Config_Project_Env_Var);
445
446 declare
447 T : constant String := Tmp.all;
448 begin
449 Free (Tmp);
450
451 if T'Length = 0 then
452 return Default_Name;
453 else
454 return T;
455 end if;
456 end;
457 end if;
458 end Default_File_Name;
459
460 ------------------------
461 -- Might_Have_Sources --
462 ------------------------
463
464 function Might_Have_Sources (Project : Project_Id) return Boolean is
465 Variable : Variable_Value;
466
467 begin
468 Variable :=
469 Value_Of
470 (Name_Source_Dirs,
471 Project.Decl.Attributes,
472 Project_Tree);
473
474 if Variable = Nil_Variable_Value
475 or else Variable.Default
476 or else Variable.Values /= Nil_String
477 then
478 Variable :=
479 Value_Of
480 (Name_Source_Files,
481 Project.Decl.Attributes,
482 Project_Tree);
483 return Variable = Nil_Variable_Value
484 or else Variable.Default
485 or else Variable.Values /= Nil_String;
486
487 else
488 return False;
489 end if;
490 end Might_Have_Sources;
491
492 -------------------------
493 -- Get_Config_Switches --
494 -------------------------
495
496 function Get_Config_Switches return Argument_List_Access is
497 package Language_Htable is new GNAT.HTable.Simple_HTable
498 (Header_Num => Prj.Header_Num,
499 Element => Name_Id,
500 No_Element => No_Name,
501 Key => Name_Id,
502 Hash => Prj.Hash,
503 Equal => "=");
504 -- Hash table to keep the languages used in the project tree
505
506 IDE : constant Package_Id :=
507 Value_Of
508 (Name_Ide,
509 Project.Decl.Packages,
510 Project_Tree);
511
512 Prj_Iter : Project_List;
513 List : String_List_Id;
514 Elem : String_Element;
515 Lang : Name_Id;
516 Variable : Variable_Value;
517 Name : Name_Id;
518 Count : Natural;
519 Result : Argument_List_Access;
520
521 Check_Default : Boolean;
522
523 begin
524 Prj_Iter := Project_Tree.Projects;
525 while Prj_Iter /= null loop
526 if Might_Have_Sources (Prj_Iter.Project) then
527 Variable :=
528 Value_Of
529 (Name_Languages,
530 Prj_Iter.Project.Decl.Attributes,
531 Project_Tree);
532
533 if Variable = Nil_Variable_Value
534 or else Variable.Default
535 then
536 -- Languages is not declared. If it is not an extending
537 -- project, or if it extends a project with no Languages,
538 -- check for Default_Language.
539
540 Check_Default := Prj_Iter.Project.Extends = No_Project;
541
542 if not Check_Default then
543 Variable :=
544 Value_Of
545 (Name_Languages,
546 Prj_Iter.Project.Extends.Decl.Attributes,
547 Project_Tree);
548 Check_Default :=
549 Variable /= Nil_Variable_Value
550 and then Variable.Values = Nil_String;
551 end if;
552
553 if Check_Default then
554 Variable :=
555 Value_Of
556 (Name_Default_Language,
557 Prj_Iter.Project.Decl.Attributes,
558 Project_Tree);
559
560 if Variable /= Nil_Variable_Value
561 and then not Variable.Default
562 then
563 Get_Name_String (Variable.Value);
564 To_Lower (Name_Buffer (1 .. Name_Len));
565 Lang := Name_Find;
566 Language_Htable.Set (Lang, Lang);
567
568 else
569 -- If no default language is declared, default to Ada
570
571 Language_Htable.Set (Name_Ada, Name_Ada);
572 end if;
573 end if;
574
575 elsif Variable.Values /= Nil_String then
576
577 -- Attribute Languages is declared with a non empty
578 -- list: put all the languages in Language_HTable.
579
580 List := Variable.Values;
581 while List /= Nil_String loop
582 Elem := Project_Tree.String_Elements.Table (List);
583
584 Get_Name_String (Elem.Value);
585 To_Lower (Name_Buffer (1 .. Name_Len));
586 Lang := Name_Find;
587 Language_Htable.Set (Lang, Lang);
588
589 List := Elem.Next;
590 end loop;
591 end if;
592 end if;
593
594 Prj_Iter := Prj_Iter.Next;
595 end loop;
596
597 Name := Language_Htable.Get_First;
598 Count := 0;
599 while Name /= No_Name loop
600 Count := Count + 1;
601 Name := Language_Htable.Get_Next;
602 end loop;
603
604 Result := new String_List (1 .. Count);
605
606 Count := 1;
607 Name := Language_Htable.Get_First;
608 while Name /= No_Name loop
609 -- Check if IDE'Compiler_Command is declared for the language.
610 -- If it is, use its value to invoke gprconfig.
611
612 Variable :=
613 Value_Of
614 (Name,
615 Attribute_Or_Array_Name => Name_Compiler_Command,
616 In_Package => IDE,
617 In_Tree => Project_Tree,
618 Force_Lower_Case_Index => True);
619
620 declare
621 Config_Command : constant String :=
622 "--config=" & Get_Name_String (Name);
623
624 Runtime_Name : constant String :=
625 Runtime_Name_For (Name);
626
627 begin
628 if Variable = Nil_Variable_Value
629 or else Length_Of_Name (Variable.Value) = 0
630 then
631 Result (Count) :=
632 new String'(Config_Command & ",," & Runtime_Name);
633
634 else
635 declare
636 Compiler_Command : constant String :=
637 Get_Name_String (Variable.Value);
638
639 begin
640 if Is_Absolute_Path (Compiler_Command) then
641 Result (Count) :=
642 new String'
643 (Config_Command & ",," & Runtime_Name & "," &
644 Containing_Directory (Compiler_Command) & "," &
645 Simple_Name (Compiler_Command));
646 else
647 Result (Count) :=
648 new String'
649 (Config_Command & ",," & Runtime_Name & ",," &
650 Compiler_Command);
651 end if;
652 end;
653 end if;
654 end;
655
656 Count := Count + 1;
657 Name := Language_Htable.Get_Next;
658 end loop;
659
660 return Result;
661 end Get_Config_Switches;
662
663 -----------------
664 -- Do_Autoconf --
665 -----------------
666
667 procedure Do_Autoconf is
668 Obj_Dir : constant Variable_Value :=
669 Value_Of
670 (Name_Object_Dir,
671 Project.Decl.Attributes,
672 Project_Tree);
673
674 Gprconfig_Path : String_Access;
675 Success : Boolean;
676
677 begin
678 Gprconfig_Path := Locate_Exec_On_Path (Gprconfig_Name);
679
680 if Gprconfig_Path = null then
681 raise Invalid_Config
682 with "could not locate gprconfig for auto-configuration";
683 end if;
684
685 -- First, find the object directory of the user's project
686
687 if Obj_Dir = Nil_Variable_Value or else Obj_Dir.Default then
688 Get_Name_String (Project.Directory.Name);
689
690 else
691 if Is_Absolute_Path (Get_Name_String (Obj_Dir.Value)) then
692 Get_Name_String (Obj_Dir.Value);
693
694 else
695 Name_Len := 0;
696 Add_Str_To_Name_Buffer
697 (Get_Name_String (Project.Directory.Name));
698 Add_Str_To_Name_Buffer (Get_Name_String (Obj_Dir.Value));
699 end if;
700 end if;
701
702 if Subdirs /= null then
703 Add_Char_To_Name_Buffer (Directory_Separator);
704 Add_Str_To_Name_Buffer (Subdirs.all);
705 end if;
706
707 for J in 1 .. Name_Len loop
708 if Name_Buffer (J) = '/' then
709 Name_Buffer (J) := Directory_Separator;
710 end if;
711 end loop;
712
713 declare
714 Obj_Dir : constant String := Name_Buffer (1 .. Name_Len);
715 Switches : Argument_List_Access := Get_Config_Switches;
716 Args : Argument_List (1 .. 5);
717 Arg_Last : Positive;
718
719 Obj_Dir_Exists : Boolean := True;
720
721 begin
722 -- Check if the object directory exists. If Setup_Projects is True
723 -- (-p) and directory does not exist, attempt to create it.
724 -- Otherwise, if directory does not exist, fail without calling
725 -- gprconfig.
726
727 if not Is_Directory (Obj_Dir)
728 and then (Setup_Projects or else Subdirs /= null)
729 then
730 begin
731 Create_Path (Obj_Dir);
732
733 if not Quiet_Output then
734 Write_Str ("object directory """);
735 Write_Str (Obj_Dir);
736 Write_Line (""" created");
737 end if;
738
739 exception
740 when others =>
741 raise Invalid_Config
742 with "could not create object directory " & Obj_Dir;
743 end;
744 end if;
745
746 if not Is_Directory (Obj_Dir) then
747 case Flags.Require_Obj_Dirs is
748 when Error =>
749 raise Invalid_Config
750 with "object directory " & Obj_Dir & " does not exist";
751 when Warning =>
752 Prj.Err.Error_Msg
753 (Flags,
754 "?object directory " & Obj_Dir & " does not exist");
755 Obj_Dir_Exists := False;
756 when Silent =>
757 null;
758 end case;
759 end if;
760
761 -- Invoke gprconfig
762
763 Args (1) := new String'("--batch");
764 Args (2) := new String'("-o");
765
766 -- If no config file was specified, set the auto.cgpr one
767
768 if Config_File_Name = "" then
769 if Obj_Dir_Exists then
770 Args (3) :=
771 new String'(Obj_Dir & Directory_Separator & Auto_Cgpr);
772
773 else
774 declare
775 Path_FD : File_Descriptor;
776 Path_Name : Path_Name_Type;
777
778 begin
779 Prj.Env.Create_Temp_File
780 (In_Tree => Project_Tree,
781 Path_FD => Path_FD,
782 Path_Name => Path_Name,
783 File_Use => "configuration file");
784
785 if Path_FD /= Invalid_FD then
786 Args (3) := new String'(Get_Name_String (Path_Name));
787 GNAT.OS_Lib.Close (Path_FD);
788
789 else
790 -- We'll have an error message later on
791
792 Args (3) :=
793 new String'
794 (Obj_Dir & Directory_Separator & Auto_Cgpr);
795 end if;
796 end;
797 end if;
798 else
799 Args (3) := new String'(Config_File_Name);
800 end if;
801
802 if Normalized_Hostname = "" then
803 Arg_Last := 3;
804 else
805 if Target_Name = "" then
806 Args (4) := new String'("--target=" & Normalized_Hostname);
807 else
808 Args (4) := new String'("--target=" & Target_Name);
809 end if;
810
811 Arg_Last := 4;
812 end if;
813
814 if not Verbose_Mode then
815 Arg_Last := Arg_Last + 1;
816 Args (Arg_Last) := new String'("-q");
817 end if;
818
819 if Verbose_Mode then
820 Write_Str (Gprconfig_Name);
821
822 for J in 1 .. Arg_Last loop
823 Write_Char (' ');
824 Write_Str (Args (J).all);
825 end loop;
826
827 for J in Switches'Range loop
828 Write_Char (' ');
829 Write_Str (Switches (J).all);
830 end loop;
831
832 Write_Eol;
833
834 elsif not Quiet_Output then
835 -- Display no message if we are creating auto.cgpr, unless in
836 -- verbose mode
837
838 if Config_File_Name /= ""
839 or else Verbose_Mode
840 then
841 Write_Str ("creating ");
842 Write_Str (Simple_Name (Args (3).all));
843 Write_Eol;
844 end if;
845 end if;
846
847 Spawn (Gprconfig_Path.all, Args (1 .. Arg_Last) & Switches.all,
848 Success);
849
850 Free (Switches);
851
852 Config_File_Path := Locate_Config_File (Args (3).all);
853
854 if Config_File_Path = null then
855 raise Invalid_Config
856 with "could not create " & Args (3).all;
857 end if;
858
859 for F in Args'Range loop
860 Free (Args (F));
861 end loop;
862 end;
863 end Do_Autoconf;
864
865 Success : Boolean;
866 Config_Project_Node : Project_Node_Id := Empty_Node;
867
868 begin
869 Free (Config_File_Path);
870 Config := No_Project;
871
872 if Config_File_Name /= "" then
873 Config_File_Path := Locate_Config_File (Config_File_Name);
874 else
875 Config_File_Path := Locate_Config_File (Default_File_Name);
876 end if;
877
878 if Config_File_Path = null then
879 if (not Allow_Automatic_Generation) and then
880 Config_File_Name /= ""
881 then
882 raise Invalid_Config
883 with "could not locate main configuration project "
884 & Config_File_Name;
885 end if;
886 end if;
887
888 Automatically_Generated :=
889 Allow_Automatic_Generation and then Config_File_Path = null;
890
891 <<Process_Config_File>>
892
893 if Automatically_Generated then
894 if Hostparm.OpenVMS then
895
896 -- There is no gprconfig on VMS
897
898 raise Invalid_Config
899 with "could not locate any configuration project file";
900
901 else
902 -- This might raise an Invalid_Config exception
903
904 Do_Autoconf;
905 end if;
906 end if;
907
908 -- Parse the configuration file
909
910 if Verbose_Mode and then Config_File_Path /= null then
911 Write_Str ("Checking configuration ");
912 Write_Line (Config_File_Path.all);
913 end if;
914
915 if Config_File_Path /= null then
916 Prj.Part.Parse
917 (In_Tree => Project_Node_Tree,
918 Project => Config_Project_Node,
919 Project_File_Name => Config_File_Path.all,
920 Always_Errout_Finalize => False,
921 Packages_To_Check => Packages_To_Check,
922 Current_Directory => Current_Directory,
923 Is_Config_File => True,
924 Flags => Flags);
925 else
926 -- Maybe the user will want to create his own configuration file
927 Config_Project_Node := Empty_Node;
928 end if;
929
930 if On_Load_Config /= null then
931 On_Load_Config
932 (Config_File => Config_Project_Node,
933 Project_Node_Tree => Project_Node_Tree);
934 end if;
935
936 if Config_Project_Node /= Empty_Node then
937 Prj.Proc.Process_Project_Tree_Phase_1
938 (In_Tree => Project_Tree,
939 Project => Config,
940 Success => Success,
941 From_Project_Node => Config_Project_Node,
942 From_Project_Node_Tree => Project_Node_Tree,
943 Flags => Flags,
944 Reset_Tree => False);
945 end if;
946
947 if Config_Project_Node = Empty_Node
948 or else Config = No_Project
949 then
950 raise Invalid_Config
951 with "processing of configuration project """
952 & Config_File_Path.all & """ failed";
953 end if;
954
955 -- Check that the target of the configuration file is the one the user
956 -- specified on the command line. We do not need to check that when in
957 -- auto-conf mode, since the appropriate target was passed to gprconfig.
958
959 if not Automatically_Generated
960 and then not
961 Check_Target (Config, Autoconf_Specified, Project_Tree, Target_Name)
962 then
963 Automatically_Generated := True;
964 goto Process_Config_File;
965 end if;
966 end Get_Or_Create_Configuration_File;
967
968 --------------------------------------
969 -- Process_Project_And_Apply_Config --
970 --------------------------------------
971
972 procedure Process_Project_And_Apply_Config
973 (Main_Project : out Prj.Project_Id;
974 User_Project_Node : Prj.Tree.Project_Node_Id;
975 Config_File_Name : String := "";
976 Autoconf_Specified : Boolean;
977 Project_Tree : Prj.Project_Tree_Ref;
978 Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
979 Packages_To_Check : String_List_Access;
980 Allow_Automatic_Generation : Boolean := True;
981 Automatically_Generated : out Boolean;
982 Config_File_Path : out String_Access;
983 Target_Name : String := "";
984 Normalized_Hostname : String;
985 Flags : Processing_Flags;
986 On_Load_Config : Config_File_Hook := null;
987 Reset_Tree : Boolean := True)
988 is
989 Main_Config_Project : Project_Id;
990 Success : Boolean;
991
992 begin
993 Main_Project := No_Project;
994 Automatically_Generated := False;
995
996 Process_Project_Tree_Phase_1
997 (In_Tree => Project_Tree,
998 Project => Main_Project,
999 Success => Success,
1000 From_Project_Node => User_Project_Node,
1001 From_Project_Node_Tree => Project_Node_Tree,
1002 Flags => Flags,
1003 Reset_Tree => Reset_Tree);
1004
1005 if not Success then
1006 Main_Project := No_Project;
1007 return;
1008 end if;
1009
1010 -- Find configuration file
1011
1012 Get_Or_Create_Configuration_File
1013 (Config => Main_Config_Project,
1014 Project => Main_Project,
1015 Project_Tree => Project_Tree,
1016 Project_Node_Tree => Project_Node_Tree,
1017 Allow_Automatic_Generation => Allow_Automatic_Generation,
1018 Config_File_Name => Config_File_Name,
1019 Autoconf_Specified => Autoconf_Specified,
1020 Target_Name => Target_Name,
1021 Normalized_Hostname => Normalized_Hostname,
1022 Packages_To_Check => Packages_To_Check,
1023 Config_File_Path => Config_File_Path,
1024 Automatically_Generated => Automatically_Generated,
1025 Flags => Flags,
1026 On_Load_Config => On_Load_Config);
1027
1028 Apply_Config_File (Main_Config_Project, Project_Tree);
1029
1030 -- Finish processing the user's project
1031
1032 Prj.Proc.Process_Project_Tree_Phase_2
1033 (In_Tree => Project_Tree,
1034 Project => Main_Project,
1035 Success => Success,
1036 From_Project_Node => User_Project_Node,
1037 From_Project_Node_Tree => Project_Node_Tree,
1038 Flags => Flags);
1039
1040 if not Success then
1041 Main_Project := No_Project;
1042 end if;
1043 end Process_Project_And_Apply_Config;
1044
1045 ------------------------------------
1046 -- Parse_Project_And_Apply_Config --
1047 ------------------------------------
1048
1049 procedure Parse_Project_And_Apply_Config
1050 (Main_Project : out Prj.Project_Id;
1051 User_Project_Node : out Prj.Tree.Project_Node_Id;
1052 Config_File_Name : String := "";
1053 Autoconf_Specified : Boolean;
1054 Project_File_Name : String;
1055 Project_Tree : Prj.Project_Tree_Ref;
1056 Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
1057 Packages_To_Check : String_List_Access;
1058 Allow_Automatic_Generation : Boolean := True;
1059 Automatically_Generated : out Boolean;
1060 Config_File_Path : out String_Access;
1061 Target_Name : String := "";
1062 Normalized_Hostname : String;
1063 Flags : Processing_Flags;
1064 On_Load_Config : Config_File_Hook := null)
1065 is
1066 begin
1067 -- Parse the user project tree
1068
1069 Prj.Initialize (Project_Tree);
1070
1071 Main_Project := No_Project;
1072 Automatically_Generated := False;
1073
1074 Prj.Part.Parse
1075 (In_Tree => Project_Node_Tree,
1076 Project => User_Project_Node,
1077 Project_File_Name => Project_File_Name,
1078 Always_Errout_Finalize => False,
1079 Packages_To_Check => Packages_To_Check,
1080 Current_Directory => Current_Directory,
1081 Is_Config_File => False,
1082 Flags => Flags);
1083
1084 if User_Project_Node = Empty_Node then
1085 User_Project_Node := Empty_Node;
1086 return;
1087 end if;
1088
1089 Process_Project_And_Apply_Config
1090 (Main_Project => Main_Project,
1091 User_Project_Node => User_Project_Node,
1092 Config_File_Name => Config_File_Name,
1093 Autoconf_Specified => Autoconf_Specified,
1094 Project_Tree => Project_Tree,
1095 Project_Node_Tree => Project_Node_Tree,
1096 Packages_To_Check => Packages_To_Check,
1097 Allow_Automatic_Generation => Allow_Automatic_Generation,
1098 Automatically_Generated => Automatically_Generated,
1099 Config_File_Path => Config_File_Path,
1100 Target_Name => Target_Name,
1101 Normalized_Hostname => Normalized_Hostname,
1102 Flags => Flags,
1103 On_Load_Config => On_Load_Config);
1104 end Parse_Project_And_Apply_Config;
1105
1106 -----------------------
1107 -- Apply_Config_File --
1108 -----------------------
1109
1110 procedure Apply_Config_File
1111 (Config_File : Prj.Project_Id;
1112 Project_Tree : Prj.Project_Tree_Ref)
1113 is
1114 Conf_Decl : constant Declarations := Config_File.Decl;
1115 Conf_Pack_Id : Package_Id;
1116 Conf_Pack : Package_Element;
1117
1118 User_Decl : Declarations;
1119 User_Pack_Id : Package_Id;
1120 User_Pack : Package_Element;
1121 Proj : Project_List;
1122
1123 begin
1124 Proj := Project_Tree.Projects;
1125 while Proj /= null loop
1126 if Proj.Project /= Config_File then
1127 User_Decl := Proj.Project.Decl;
1128 Add_Attributes
1129 (Project_Tree => Project_Tree,
1130 Conf_Decl => Conf_Decl,
1131 User_Decl => User_Decl);
1132
1133 Conf_Pack_Id := Conf_Decl.Packages;
1134 while Conf_Pack_Id /= No_Package loop
1135 Conf_Pack := Project_Tree.Packages.Table (Conf_Pack_Id);
1136
1137 User_Pack_Id := User_Decl.Packages;
1138 while User_Pack_Id /= No_Package loop
1139 User_Pack := Project_Tree.Packages.Table (User_Pack_Id);
1140 exit when User_Pack.Name = Conf_Pack.Name;
1141 User_Pack_Id := User_Pack.Next;
1142 end loop;
1143
1144 if User_Pack_Id = No_Package then
1145 Package_Table.Increment_Last (Project_Tree.Packages);
1146 User_Pack := Conf_Pack;
1147 User_Pack.Next := User_Decl.Packages;
1148 User_Decl.Packages :=
1149 Package_Table.Last (Project_Tree.Packages);
1150 Project_Tree.Packages.Table (User_Decl.Packages) :=
1151 User_Pack;
1152
1153 else
1154 Add_Attributes
1155 (Project_Tree => Project_Tree,
1156 Conf_Decl => Conf_Pack.Decl,
1157 User_Decl => Project_Tree.Packages.Table
1158 (User_Pack_Id).Decl);
1159 end if;
1160
1161 Conf_Pack_Id := Conf_Pack.Next;
1162 end loop;
1163
1164 Proj.Project.Decl := User_Decl;
1165 end if;
1166
1167 Proj := Proj.Next;
1168 end loop;
1169 end Apply_Config_File;
1170
1171 ---------------------
1172 -- Set_Runtime_For --
1173 ---------------------
1174
1175 procedure Set_Runtime_For (Language : Name_Id; RTS_Name : String) is
1176 begin
1177 Name_Len := RTS_Name'Length;
1178 Name_Buffer (1 .. Name_Len) := RTS_Name;
1179 RTS_Languages.Set (Language, Name_Find);
1180 end Set_Runtime_For;
1181
1182 ----------------------
1183 -- Runtime_Name_For --
1184 ----------------------
1185
1186 function Runtime_Name_For (Language : Name_Id) return String is
1187 begin
1188 if RTS_Languages.Get (Language) /= No_Name then
1189 return Get_Name_String (RTS_Languages.Get (Language));
1190 else
1191 return "";
1192 end if;
1193 end Runtime_Name_For;
1194
1195 ------------------------------------
1196 -- Add_Default_GNAT_Naming_Scheme --
1197 ------------------------------------
1198
1199 procedure Add_Default_GNAT_Naming_Scheme
1200 (Config_File : in out Project_Node_Id;
1201 Project_Tree : Project_Node_Tree_Ref)
1202 is
1203 procedure Create_Attribute
1204 (Name : Name_Id;
1205 Value : String;
1206 Index : String := "";
1207 Pkg : Project_Node_Id := Empty_Node);
1208
1209 ----------------------
1210 -- Create_Attribute --
1211 ----------------------
1212
1213 procedure Create_Attribute
1214 (Name : Name_Id;
1215 Value : String;
1216 Index : String := "";
1217 Pkg : Project_Node_Id := Empty_Node)
1218 is
1219 Attr : Project_Node_Id;
1220 pragma Unreferenced (Attr);
1221
1222 Expr : Name_Id := No_Name;
1223 Val : Name_Id := No_Name;
1224 Parent : Project_Node_Id := Config_File;
1225 begin
1226 if Index /= "" then
1227 Name_Len := Index'Length;
1228 Name_Buffer (1 .. Name_Len) := Index;
1229 Val := Name_Find;
1230 end if;
1231
1232 if Pkg /= Empty_Node then
1233 Parent := Pkg;
1234 end if;
1235
1236 Name_Len := Value'Length;
1237 Name_Buffer (1 .. Name_Len) := Value;
1238 Expr := Name_Find;
1239
1240 Attr := Create_Attribute
1241 (Tree => Project_Tree,
1242 Prj_Or_Pkg => Parent,
1243 Name => Name,
1244 Index_Name => Val,
1245 Kind => Prj.Single,
1246 Value => Create_Literal_String (Expr, Project_Tree));
1247 end Create_Attribute;
1248
1249 -- Local variables
1250
1251 Name : Name_Id;
1252 Naming : Project_Node_Id;
1253
1254 -- Start of processing for Add_Default_GNAT_Naming_Scheme
1255
1256 begin
1257 if Config_File = Empty_Node then
1258
1259 -- Create a dummy config file is none was found
1260
1261 Name_Len := Auto_Cgpr'Length;
1262 Name_Buffer (1 .. Name_Len) := Auto_Cgpr;
1263 Name := Name_Find;
1264
1265 -- An invalid project name to avoid conflicts with user-created ones
1266
1267 Name_Len := 5;
1268 Name_Buffer (1 .. Name_Len) := "_auto";
1269
1270 Config_File :=
1271 Create_Project
1272 (In_Tree => Project_Tree,
1273 Name => Name_Find,
1274 Full_Path => Path_Name_Type (Name),
1275 Is_Config_File => True);
1276
1277 -- Setup library support
1278
1279 case MLib.Tgt.Support_For_Libraries is
1280 when None =>
1281 null;
1282
1283 when Static_Only =>
1284 Create_Attribute (Name_Library_Support, "static_only");
1285
1286 when Full =>
1287 Create_Attribute (Name_Library_Support, "full");
1288 end case;
1289
1290 if MLib.Tgt.Standalone_Library_Auto_Init_Is_Supported then
1291 Create_Attribute (Name_Library_Auto_Init_Supported, "true");
1292 else
1293 Create_Attribute (Name_Library_Auto_Init_Supported, "false");
1294 end if;
1295
1296 -- Setup Ada support (Ada is the default language here, since this
1297 -- is only called when no config file existed initially, ie for
1298 -- gnatmake).
1299
1300 Create_Attribute (Name_Default_Language, "ada");
1301
1302 Naming := Create_Package (Project_Tree, Config_File, "naming");
1303 Create_Attribute (Name_Spec_Suffix, ".ads", "ada", Pkg => Naming);
1304 Create_Attribute (Name_Separate_Suffix, ".adb", "ada", Pkg => Naming);
1305 Create_Attribute (Name_Body_Suffix, ".adb", "ada", Pkg => Naming);
1306 Create_Attribute (Name_Dot_Replacement, "-", Pkg => Naming);
1307 Create_Attribute (Name_Casing, "lowercase", Pkg => Naming);
1308
1309 if Current_Verbosity = High then
1310 Write_Line ("Automatically generated (in-memory) config file");
1311 Prj.PP.Pretty_Print
1312 (Project => Config_File,
1313 In_Tree => Project_Tree,
1314 Backward_Compatibility => False);
1315 end if;
1316 end if;
1317 end Add_Default_GNAT_Naming_Scheme;
1318
1319 end Prj.Conf;
GCC graphite test results