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