?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Fix unused warnings.
[official-gcc/graphite-test-results.git] / gcc / ada / prj-conf.adb
blobd30cf5773061c18976f06dac4e1fabc422d1cf2f
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 -- Add_Default_GNAT_Naming_Scheme --
320 ------------------------------------
321
322 procedure Add_Default_GNAT_Naming_Scheme
323 (Config_File : in out Project_Node_Id;
324 Project_Tree : Project_Node_Tree_Ref)
325 is
326 procedure Create_Attribute
327 (Name : Name_Id;
328 Value : String;
329 Index : String := "";
330 Pkg : Project_Node_Id := Empty_Node);
331
332 ----------------------
333 -- Create_Attribute --
334 ----------------------
335
336 procedure Create_Attribute
337 (Name : Name_Id;
338 Value : String;
339 Index : String := "";
340 Pkg : Project_Node_Id := Empty_Node)
341 is
342 Attr : Project_Node_Id;
343 pragma Unreferenced (Attr);
344
345 Expr : Name_Id := No_Name;
346 Val : Name_Id := No_Name;
347 Parent : Project_Node_Id := Config_File;
348 begin
349 if Index /= "" then
350 Name_Len := Index'Length;
351 Name_Buffer (1 .. Name_Len) := Index;
352 Val := Name_Find;
353 end if;
354
355 if Pkg /= Empty_Node then
356 Parent := Pkg;
357 end if;
358
359 Name_Len := Value'Length;
360 Name_Buffer (1 .. Name_Len) := Value;
361 Expr := Name_Find;
362
363 Attr := Create_Attribute
364 (Tree => Project_Tree,
365 Prj_Or_Pkg => Parent,
366 Name => Name,
367 Index_Name => Val,
368 Kind => Prj.Single,
369 Value => Create_Literal_String (Expr, Project_Tree));
370 end Create_Attribute;
371
372 -- Local variables
373
374 Name : Name_Id;
375 Naming : Project_Node_Id;
376
377 -- Start of processing for Add_Default_GNAT_Naming_Scheme
378
379 begin
380 if Config_File = Empty_Node then
381
382 -- Create a dummy config file is none was found
383
384 Name_Len := Auto_Cgpr'Length;
385 Name_Buffer (1 .. Name_Len) := Auto_Cgpr;
386 Name := Name_Find;
387
388 -- An invalid project name to avoid conflicts with user-created ones
389
390 Name_Len := 5;
391 Name_Buffer (1 .. Name_Len) := "_auto";
392
393 Config_File :=
394 Create_Project
395 (In_Tree => Project_Tree,
396 Name => Name_Find,
397 Full_Path => Path_Name_Type (Name),
398 Is_Config_File => True);
399
400 -- Setup library support
401
402 case MLib.Tgt.Support_For_Libraries is
403 when None =>
404 null;
405
406 when Static_Only =>
407 Create_Attribute (Name_Library_Support, "static_only");
408
409 when Full =>
410 Create_Attribute (Name_Library_Support, "full");
411 end case;
412
413 if MLib.Tgt.Standalone_Library_Auto_Init_Is_Supported then
414 Create_Attribute (Name_Library_Auto_Init_Supported, "true");
415 else
416 Create_Attribute (Name_Library_Auto_Init_Supported, "false");
417 end if;
418
419 -- Setup Ada support (Ada is the default language here, since this
420 -- is only called when no config file existed initially, ie for
421 -- gnatmake).
422
423 Create_Attribute (Name_Default_Language, "ada");
424
425 Naming := Create_Package (Project_Tree, Config_File, "naming");
426 Create_Attribute (Name_Spec_Suffix, ".ads", "ada", Pkg => Naming);
427 Create_Attribute (Name_Separate_Suffix, ".adb", "ada", Pkg => Naming);
428 Create_Attribute (Name_Body_Suffix, ".adb", "ada", Pkg => Naming);
429 Create_Attribute (Name_Dot_Replacement, "-", Pkg => Naming);
430 Create_Attribute (Name_Casing, "lowercase", Pkg => Naming);
431
432 if Current_Verbosity = High then
433 Write_Line ("Automatically generated (in-memory) config file");
434 Prj.PP.Pretty_Print
435 (Project => Config_File,
436 In_Tree => Project_Tree,
437 Backward_Compatibility => False);
438 end if;
439 end if;
440 end Add_Default_GNAT_Naming_Scheme;
441
442 -----------------------
443 -- Apply_Config_File --
444 -----------------------
445
446 procedure Apply_Config_File
447 (Config_File : Prj.Project_Id;
448 Project_Tree : Prj.Project_Tree_Ref)
449 is
450 Conf_Decl : constant Declarations := Config_File.Decl;
451 Conf_Pack_Id : Package_Id;
452 Conf_Pack : Package_Element;
453
454 User_Decl : Declarations;
455 User_Pack_Id : Package_Id;
456 User_Pack : Package_Element;
457 Proj : Project_List;
458
459 begin
460 Proj := Project_Tree.Projects;
461 while Proj /= null loop
462 if Proj.Project /= Config_File then
463 User_Decl := Proj.Project.Decl;
464 Add_Attributes
465 (Project_Tree => Project_Tree,
466 Conf_Decl => Conf_Decl,
467 User_Decl => User_Decl);
468
469 Conf_Pack_Id := Conf_Decl.Packages;
470 while Conf_Pack_Id /= No_Package loop
471 Conf_Pack := Project_Tree.Packages.Table (Conf_Pack_Id);
472
473 User_Pack_Id := User_Decl.Packages;
474 while User_Pack_Id /= No_Package loop
475 User_Pack := Project_Tree.Packages.Table (User_Pack_Id);
476 exit when User_Pack.Name = Conf_Pack.Name;
477 User_Pack_Id := User_Pack.Next;
478 end loop;
479
480 if User_Pack_Id = No_Package then
481 Package_Table.Increment_Last (Project_Tree.Packages);
482 User_Pack := Conf_Pack;
483 User_Pack.Next := User_Decl.Packages;
484 User_Decl.Packages :=
485 Package_Table.Last (Project_Tree.Packages);
486 Project_Tree.Packages.Table (User_Decl.Packages) :=
487 User_Pack;
488
489 else
490 Add_Attributes
491 (Project_Tree => Project_Tree,
492 Conf_Decl => Conf_Pack.Decl,
493 User_Decl => Project_Tree.Packages.Table
494 (User_Pack_Id).Decl);
495 end if;
496
497 Conf_Pack_Id := Conf_Pack.Next;
498 end loop;
499
500 Proj.Project.Decl := User_Decl;
501 end if;
502
503 Proj := Proj.Next;
504 end loop;
505 end Apply_Config_File;
506
507 ------------------
508 -- Check_Target --
509 ------------------
510
511 function Check_Target
512 (Config_File : Project_Id;
513 Autoconf_Specified : Boolean;
514 Project_Tree : Prj.Project_Tree_Ref;
515 Target : String := "") return Boolean
516 is
517 Variable : constant Variable_Value :=
518 Value_Of
519 (Name_Target, Config_File.Decl.Attributes, Project_Tree);
520 Tgt_Name : Name_Id := No_Name;
521 OK : Boolean;
522
523 begin
524 if Variable /= Nil_Variable_Value and then not Variable.Default then
525 Tgt_Name := Variable.Value;
526 end if;
527
528 if Target = "" then
529 OK := not Autoconf_Specified or else Tgt_Name = No_Name;
530 else
531 OK := Tgt_Name /= No_Name
532 and then Target = Get_Name_String (Tgt_Name);
533 end if;
534
535 if not OK then
536 if Autoconf_Specified then
537 if Verbose_Mode then
538 Write_Line ("inconsistent targets, performing autoconf");
539 end if;
540
541 return False;
542
543 else
544 if Tgt_Name /= No_Name then
545 raise Invalid_Config
546 with "invalid target name """
547 & Get_Name_String (Tgt_Name) & """ in configuration";
548
549 else
550 raise Invalid_Config
551 with "no target specified in configuration file";
552 end if;
553 end if;
554 end if;
555
556 return True;
557 end Check_Target;
558
559 --------------------------------------
560 -- Get_Or_Create_Configuration_File --
561 --------------------------------------
562
563 procedure Get_Or_Create_Configuration_File
564 (Project : Project_Id;
565 Project_Tree : Project_Tree_Ref;
566 Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
567 Allow_Automatic_Generation : Boolean;
568 Config_File_Name : String := "";
569 Autoconf_Specified : Boolean;
570 Target_Name : String := "";
571 Normalized_Hostname : String;
572 Packages_To_Check : String_List_Access := null;
573 Config : out Prj.Project_Id;
574 Config_File_Path : out String_Access;
575 Automatically_Generated : out Boolean;
576 Flags : Processing_Flags;
577 On_Load_Config : Config_File_Hook := null)
578 is
579 function Default_File_Name return String;
580 -- Return the name of the default config file that should be tested
581
582 procedure Do_Autoconf;
583 -- Generate a new config file through gprconfig.
584 -- In case of error, this raises the Invalid_Config exception with an
585 -- appropriate message
586
587 function Get_Config_Switches return Argument_List_Access;
588 -- Return the --config switches to use for gprconfig
589
590 function Might_Have_Sources (Project : Project_Id) return Boolean;
591 -- True if the specified project might have sources (ie the user has not
592 -- explicitly specified it. We haven't checked the file system, nor do
593 -- we need to at this stage.
594
595 -----------------------
596 -- Default_File_Name --
597 -----------------------
598
599 function Default_File_Name return String is
600 Ada_RTS : constant String := Runtime_Name_For (Name_Ada);
601 Tmp : String_Access;
602
603 begin
604 if Target_Name /= "" then
605 if Ada_RTS /= "" then
606 return Target_Name & '-' & Ada_RTS
607 & Config_Project_File_Extension;
608 else
609 return Target_Name & Config_Project_File_Extension;
610 end if;
611
612 elsif Ada_RTS /= "" then
613 return Ada_RTS & Config_Project_File_Extension;
614
615 else
616 Tmp := Getenv (Config_Project_Env_Var);
617
618 declare
619 T : constant String := Tmp.all;
620 begin
621 Free (Tmp);
622
623 if T'Length = 0 then
624 return Default_Name;
625 else
626 return T;
627 end if;
628 end;
629 end if;
630 end Default_File_Name;
631
632 ------------------------
633 -- Might_Have_Sources --
634 ------------------------
635
636 function Might_Have_Sources (Project : Project_Id) return Boolean is
637 Variable : Variable_Value;
638
639 begin
640 Variable :=
641 Value_Of
642 (Name_Source_Dirs,
643 Project.Decl.Attributes,
644 Project_Tree);
645
646 if Variable = Nil_Variable_Value
647 or else Variable.Default
648 or else Variable.Values /= Nil_String
649 then
650 Variable :=
651 Value_Of
652 (Name_Source_Files,
653 Project.Decl.Attributes,
654 Project_Tree);
655 return Variable = Nil_Variable_Value
656 or else Variable.Default
657 or else Variable.Values /= Nil_String;
658
659 else
660 return False;
661 end if;
662 end Might_Have_Sources;
663
664 -------------------------
665 -- Get_Config_Switches --
666 -------------------------
667
668 function Get_Config_Switches return Argument_List_Access is
669 package Language_Htable is new GNAT.HTable.Simple_HTable
670 (Header_Num => Prj.Header_Num,
671 Element => Name_Id,
672 No_Element => No_Name,
673 Key => Name_Id,
674 Hash => Prj.Hash,
675 Equal => "=");
676 -- Hash table to keep the languages used in the project tree
677
678 IDE : constant Package_Id :=
679 Value_Of
680 (Name_Ide,
681 Project.Decl.Packages,
682 Project_Tree);
683
684 Prj_Iter : Project_List;
685 List : String_List_Id;
686 Elem : String_Element;
687 Lang : Name_Id;
688 Variable : Variable_Value;
689 Name : Name_Id;
690 Count : Natural;
691 Result : Argument_List_Access;
692
693 Check_Default : Boolean;
694
695 begin
696 Prj_Iter := Project_Tree.Projects;
697 while Prj_Iter /= null loop
698 if Might_Have_Sources (Prj_Iter.Project) then
699 Variable :=
700 Value_Of
701 (Name_Languages,
702 Prj_Iter.Project.Decl.Attributes,
703 Project_Tree);
704
705 if Variable = Nil_Variable_Value
706 or else Variable.Default
707 then
708 -- Languages is not declared. If it is not an extending
709 -- project, or if it extends a project with no Languages,
710 -- check for Default_Language.
711
712 Check_Default := Prj_Iter.Project.Extends = No_Project;
713
714 if not Check_Default then
715 Variable :=
716 Value_Of
717 (Name_Languages,
718 Prj_Iter.Project.Extends.Decl.Attributes,
719 Project_Tree);
720 Check_Default :=
721 Variable /= Nil_Variable_Value
722 and then Variable.Values = Nil_String;
723 end if;
724
725 if Check_Default then
726 Variable :=
727 Value_Of
728 (Name_Default_Language,
729 Prj_Iter.Project.Decl.Attributes,
730 Project_Tree);
731
732 if Variable /= Nil_Variable_Value
733 and then not Variable.Default
734 then
735 Get_Name_String (Variable.Value);
736 To_Lower (Name_Buffer (1 .. Name_Len));
737 Lang := Name_Find;
738 Language_Htable.Set (Lang, Lang);
739
740 else
741 -- If no default language is declared, default to Ada
742
743 Language_Htable.Set (Name_Ada, Name_Ada);
744 end if;
745 end if;
746
747 elsif Variable.Values /= Nil_String then
748
749 -- Attribute Languages is declared with a non empty
750 -- list: put all the languages in Language_HTable.
751
752 List := Variable.Values;
753 while List /= Nil_String loop
754 Elem := Project_Tree.String_Elements.Table (List);
755
756 Get_Name_String (Elem.Value);
757 To_Lower (Name_Buffer (1 .. Name_Len));
758 Lang := Name_Find;
759 Language_Htable.Set (Lang, Lang);
760
761 List := Elem.Next;
762 end loop;
763 end if;
764 end if;
765
766 Prj_Iter := Prj_Iter.Next;
767 end loop;
768
769 Name := Language_Htable.Get_First;
770 Count := 0;
771 while Name /= No_Name loop
772 Count := Count + 1;
773 Name := Language_Htable.Get_Next;
774 end loop;
775
776 Result := new String_List (1 .. Count);
777
778 Count := 1;
779 Name := Language_Htable.Get_First;
780 while Name /= No_Name loop
781 -- Check if IDE'Compiler_Command is declared for the language.
782 -- If it is, use its value to invoke gprconfig.
783
784 Variable :=
785 Value_Of
786 (Name,
787 Attribute_Or_Array_Name => Name_Compiler_Command,
788 In_Package => IDE,
789 In_Tree => Project_Tree,
790 Force_Lower_Case_Index => True);
791
792 declare
793 Config_Command : constant String :=
794 "--config=" & Get_Name_String (Name);
795
796 Runtime_Name : constant String :=
797 Runtime_Name_For (Name);
798
799 begin
800 if Variable = Nil_Variable_Value
801 or else Length_Of_Name (Variable.Value) = 0
802 then
803 Result (Count) :=
804 new String'(Config_Command & ",," & Runtime_Name);
805
806 else
807 declare
808 Compiler_Command : constant String :=
809 Get_Name_String (Variable.Value);
810
811 begin
812 if Is_Absolute_Path (Compiler_Command) then
813 Result (Count) :=
814 new String'
815 (Config_Command & ",," & Runtime_Name & "," &
816 Containing_Directory (Compiler_Command) & "," &
817 Simple_Name (Compiler_Command));
818 else
819 Result (Count) :=
820 new String'
821 (Config_Command & ",," & Runtime_Name & ",," &
822 Compiler_Command);
823 end if;
824 end;
825 end if;
826 end;
827
828 Count := Count + 1;
829 Name := Language_Htable.Get_Next;
830 end loop;
831
832 return Result;
833 end Get_Config_Switches;
834
835 -----------------
836 -- Do_Autoconf --
837 -----------------
838
839 procedure Do_Autoconf is
840 Obj_Dir : constant Variable_Value :=
841 Value_Of
842 (Name_Object_Dir,
843 Project.Decl.Attributes,
844 Project_Tree);
845
846 Gprconfig_Path : String_Access;
847 Success : Boolean;
848
849 begin
850 Gprconfig_Path := Locate_Exec_On_Path (Gprconfig_Name);
851
852 if Gprconfig_Path = null then
853 raise Invalid_Config
854 with "could not locate gprconfig for auto-configuration";
855 end if;
856
857 -- First, find the object directory of the user's project
858
859 if Obj_Dir = Nil_Variable_Value or else Obj_Dir.Default then
860 Get_Name_String (Project.Directory.Display_Name);
861
862 else
863 if Is_Absolute_Path (Get_Name_String (Obj_Dir.Value)) then
864 Get_Name_String (Obj_Dir.Value);
865
866 else
867 Name_Len := 0;
868 Add_Str_To_Name_Buffer
869 (Get_Name_String (Project.Directory.Display_Name));
870 Add_Str_To_Name_Buffer (Get_Name_String (Obj_Dir.Value));
871 end if;
872 end if;
873
874 if Subdirs /= null then
875 Add_Char_To_Name_Buffer (Directory_Separator);
876 Add_Str_To_Name_Buffer (Subdirs.all);
877 end if;
878
879 for J in 1 .. Name_Len loop
880 if Name_Buffer (J) = '/' then
881 Name_Buffer (J) := Directory_Separator;
882 end if;
883 end loop;
884
885 declare
886 Obj_Dir : constant String := Name_Buffer (1 .. Name_Len);
887 Switches : Argument_List_Access := Get_Config_Switches;
888 Args : Argument_List (1 .. 5);
889 Arg_Last : Positive;
890
891 Obj_Dir_Exists : Boolean := True;
892
893 begin
894 -- Check if the object directory exists. If Setup_Projects is True
895 -- (-p) and directory does not exist, attempt to create it.
896 -- Otherwise, if directory does not exist, fail without calling
897 -- gprconfig.
898
899 if not Is_Directory (Obj_Dir)
900 and then (Setup_Projects or else Subdirs /= null)
901 then
902 begin
903 Create_Path (Obj_Dir);
904
905 if not Quiet_Output then
906 Write_Str ("object directory """);
907 Write_Str (Obj_Dir);
908 Write_Line (""" created");
909 end if;
910
911 exception
912 when others =>
913 raise Invalid_Config
914 with "could not create object directory " & Obj_Dir;
915 end;
916 end if;
917
918 if not Is_Directory (Obj_Dir) then
919 case Flags.Require_Obj_Dirs is
920 when Error =>
921 raise Invalid_Config
922 with "object directory " & Obj_Dir & " does not exist";
923 when Warning =>
924 Prj.Err.Error_Msg
925 (Flags,
926 "?object directory " & Obj_Dir & " does not exist");
927 Obj_Dir_Exists := False;
928 when Silent =>
929 null;
930 end case;
931 end if;
932
933 -- Invoke gprconfig
934
935 Args (1) := new String'("--batch");
936 Args (2) := new String'("-o");
937
938 -- If no config file was specified, set the auto.cgpr one
939
940 if Config_File_Name = "" then
941 if Obj_Dir_Exists then
942 Args (3) :=
943 new String'(Obj_Dir & Directory_Separator & Auto_Cgpr);
944
945 else
946 declare
947 Path_FD : File_Descriptor;
948 Path_Name : Path_Name_Type;
949
950 begin
951 Prj.Env.Create_Temp_File
952 (In_Tree => Project_Tree,
953 Path_FD => Path_FD,
954 Path_Name => Path_Name,
955 File_Use => "configuration file");
956
957 if Path_FD /= Invalid_FD then
958 Args (3) := new String'(Get_Name_String (Path_Name));
959 GNAT.OS_Lib.Close (Path_FD);
960
961 else
962 -- We'll have an error message later on
963
964 Args (3) :=
965 new String'
966 (Obj_Dir & Directory_Separator & Auto_Cgpr);
967 end if;
968 end;
969 end if;
970 else
971 Args (3) := new String'(Config_File_Name);
972 end if;
973
974 if Normalized_Hostname = "" then
975 Arg_Last := 3;
976 else
977 if Target_Name = "" then
978 Args (4) := new String'("--target=" & Normalized_Hostname);
979 else
980 Args (4) := new String'("--target=" & Target_Name);
981 end if;
982
983 Arg_Last := 4;
984 end if;
985
986 if not Verbose_Mode then
987 Arg_Last := Arg_Last + 1;
988 Args (Arg_Last) := new String'("-q");
989 end if;
990
991 if Verbose_Mode then
992 Write_Str (Gprconfig_Name);
993
994 for J in 1 .. Arg_Last loop
995 Write_Char (' ');
996 Write_Str (Args (J).all);
997 end loop;
998
999 for J in Switches'Range loop
1000 Write_Char (' ');
1001 Write_Str (Switches (J).all);
1002 end loop;
1003
1004 Write_Eol;
1005
1006 elsif not Quiet_Output then
1007 -- Display no message if we are creating auto.cgpr, unless in
1008 -- verbose mode
1009
1010 if Config_File_Name /= ""
1011 or else Verbose_Mode
1012 then
1013 Write_Str ("creating ");
1014 Write_Str (Simple_Name (Args (3).all));
1015 Write_Eol;
1016 end if;
1017 end if;
1018
1019 Spawn (Gprconfig_Path.all, Args (1 .. Arg_Last) & Switches.all,
1020 Success);
1021
1022 Free (Switches);
1023
1024 Config_File_Path := Locate_Config_File (Args (3).all);
1025
1026 if Config_File_Path = null then
1027 raise Invalid_Config
1028 with "could not create " & Args (3).all;
1029 end if;
1030
1031 for F in Args'Range loop
1032 Free (Args (F));
1033 end loop;
1034 end;
1035 end Do_Autoconf;
1036
1037 Success : Boolean;
1038 Config_Project_Node : Project_Node_Id := Empty_Node;
1039
1040 begin
1041 Free (Config_File_Path);
1042 Config := No_Project;
1043
1044 if Config_File_Name /= "" then
1045 Config_File_Path := Locate_Config_File (Config_File_Name);
1046 else
1047 Config_File_Path := Locate_Config_File (Default_File_Name);
1048 end if;
1049
1050 if Config_File_Path = null then
1051 if (not Allow_Automatic_Generation) and then
1052 Config_File_Name /= ""
1053 then
1054 raise Invalid_Config
1055 with "could not locate main configuration project "
1056 & Config_File_Name;
1057 end if;
1058 end if;
1059
1060 Automatically_Generated :=
1061 Allow_Automatic_Generation and then Config_File_Path = null;
1062
1063 <<Process_Config_File>>
1064
1065 if Automatically_Generated then
1066 if Hostparm.OpenVMS then
1067
1068 -- There is no gprconfig on VMS
1069
1070 raise Invalid_Config
1071 with "could not locate any configuration project file";
1072
1073 else
1074 -- This might raise an Invalid_Config exception
1075
1076 Do_Autoconf;
1077 end if;
1078 end if;
1079
1080 -- Parse the configuration file
1081
1082 if Verbose_Mode and then Config_File_Path /= null then
1083 Write_Str ("Checking configuration ");
1084 Write_Line (Config_File_Path.all);
1085 end if;
1086
1087 if Config_File_Path /= null then
1088 Prj.Part.Parse
1089 (In_Tree => Project_Node_Tree,
1090 Project => Config_Project_Node,
1091 Project_File_Name => Config_File_Path.all,
1092 Always_Errout_Finalize => False,
1093 Packages_To_Check => Packages_To_Check,
1094 Current_Directory => Current_Directory,
1095 Is_Config_File => True,
1096 Flags => Flags);
1097 else
1098 -- Maybe the user will want to create his own configuration file
1099 Config_Project_Node := Empty_Node;
1100 end if;
1101
1102 if On_Load_Config /= null then
1103 On_Load_Config
1104 (Config_File => Config_Project_Node,
1105 Project_Node_Tree => Project_Node_Tree);
1106 end if;
1107
1108 if Config_Project_Node /= Empty_Node then
1109 Prj.Proc.Process_Project_Tree_Phase_1
1110 (In_Tree => Project_Tree,
1111 Project => Config,
1112 Success => Success,
1113 From_Project_Node => Config_Project_Node,
1114 From_Project_Node_Tree => Project_Node_Tree,
1115 Flags => Flags,
1116 Reset_Tree => False);
1117 end if;
1118
1119 if Config_Project_Node = Empty_Node
1120 or else Config = No_Project
1121 then
1122 raise Invalid_Config
1123 with "processing of configuration project """
1124 & Config_File_Path.all & """ failed";
1125 end if;
1126
1127 -- Check that the target of the configuration file is the one the user
1128 -- specified on the command line. We do not need to check that when in
1129 -- auto-conf mode, since the appropriate target was passed to gprconfig.
1130
1131 if not Automatically_Generated
1132 and then not
1133 Check_Target (Config, Autoconf_Specified, Project_Tree, Target_Name)
1134 then
1135 Automatically_Generated := True;
1136 goto Process_Config_File;
1137 end if;
1138 end Get_Or_Create_Configuration_File;
1139
1140 ------------------------
1141 -- Locate_Config_File --
1142 ------------------------
1143
1144 function Locate_Config_File (Name : String) return String_Access is
1145 Prefix_Path : constant String := Executable_Prefix_Path;
1146 begin
1147 if Prefix_Path'Length /= 0 then
1148 return Locate_Regular_File
1149 (Name,
1150 "." & Path_Separator &
1151 Prefix_Path & "share" & Directory_Separator & "gpr");
1152 else
1153 return Locate_Regular_File (Name, ".");
1154 end if;
1155 end Locate_Config_File;
1156
1157 ------------------------------------
1158 -- Parse_Project_And_Apply_Config --
1159 ------------------------------------
1160
1161 procedure Parse_Project_And_Apply_Config
1162 (Main_Project : out Prj.Project_Id;
1163 User_Project_Node : out Prj.Tree.Project_Node_Id;
1164 Config_File_Name : String := "";
1165 Autoconf_Specified : Boolean;
1166 Project_File_Name : String;
1167 Project_Tree : Prj.Project_Tree_Ref;
1168 Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
1169 Packages_To_Check : String_List_Access;
1170 Allow_Automatic_Generation : Boolean := True;
1171 Automatically_Generated : out Boolean;
1172 Config_File_Path : out String_Access;
1173 Target_Name : String := "";
1174 Normalized_Hostname : String;
1175 Flags : Processing_Flags;
1176 On_Load_Config : Config_File_Hook := null)
1177 is
1178 begin
1179 -- Parse the user project tree
1180
1181 Prj.Initialize (Project_Tree);
1182
1183 Main_Project := No_Project;
1184 Automatically_Generated := False;
1185
1186 Prj.Part.Parse
1187 (In_Tree => Project_Node_Tree,
1188 Project => User_Project_Node,
1189 Project_File_Name => Project_File_Name,
1190 Always_Errout_Finalize => False,
1191 Packages_To_Check => Packages_To_Check,
1192 Current_Directory => Current_Directory,
1193 Is_Config_File => False,
1194 Flags => Flags);
1195
1196 if User_Project_Node = Empty_Node then
1197 User_Project_Node := Empty_Node;
1198 return;
1199 end if;
1200
1201 Process_Project_And_Apply_Config
1202 (Main_Project => Main_Project,
1203 User_Project_Node => User_Project_Node,
1204 Config_File_Name => Config_File_Name,
1205 Autoconf_Specified => Autoconf_Specified,
1206 Project_Tree => Project_Tree,
1207 Project_Node_Tree => Project_Node_Tree,
1208 Packages_To_Check => Packages_To_Check,
1209 Allow_Automatic_Generation => Allow_Automatic_Generation,
1210 Automatically_Generated => Automatically_Generated,
1211 Config_File_Path => Config_File_Path,
1212 Target_Name => Target_Name,
1213 Normalized_Hostname => Normalized_Hostname,
1214 Flags => Flags,
1215 On_Load_Config => On_Load_Config);
1216 end Parse_Project_And_Apply_Config;
1217
1218 --------------------------------------
1219 -- Process_Project_And_Apply_Config --
1220 --------------------------------------
1221
1222 procedure Process_Project_And_Apply_Config
1223 (Main_Project : out Prj.Project_Id;
1224 User_Project_Node : Prj.Tree.Project_Node_Id;
1225 Config_File_Name : String := "";
1226 Autoconf_Specified : Boolean;
1227 Project_Tree : Prj.Project_Tree_Ref;
1228 Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
1229 Packages_To_Check : String_List_Access;
1230 Allow_Automatic_Generation : Boolean := True;
1231 Automatically_Generated : out Boolean;
1232 Config_File_Path : out String_Access;
1233 Target_Name : String := "";
1234 Normalized_Hostname : String;
1235 Flags : Processing_Flags;
1236 On_Load_Config : Config_File_Hook := null;
1237 Reset_Tree : Boolean := True)
1238 is
1239 Main_Config_Project : Project_Id;
1240 Success : Boolean;
1241
1242 begin
1243 Main_Project := No_Project;
1244 Automatically_Generated := False;
1245
1246 Process_Project_Tree_Phase_1
1247 (In_Tree => Project_Tree,
1248 Project => Main_Project,
1249 Success => Success,
1250 From_Project_Node => User_Project_Node,
1251 From_Project_Node_Tree => Project_Node_Tree,
1252 Flags => Flags,
1253 Reset_Tree => Reset_Tree);
1254
1255 if not Success then
1256 Main_Project := No_Project;
1257 return;
1258 end if;
1259
1260 if Project_Tree.Source_Info_File_Name /= null then
1261 if not Is_Absolute_Path (Project_Tree.Source_Info_File_Name.all) then
1262 declare
1263 Obj_Dir : constant Variable_Value :=
1264 Value_Of
1265 (Name_Object_Dir,
1266 Main_Project.Decl.Attributes,
1267 Project_Tree);
1268
1269 begin
1270 if Obj_Dir = Nil_Variable_Value or else Obj_Dir.Default then
1271 Get_Name_String (Main_Project.Directory.Display_Name);
1272
1273 else
1274 if Is_Absolute_Path (Get_Name_String (Obj_Dir.Value)) then
1275 Get_Name_String (Obj_Dir.Value);
1276
1277 else
1278 Name_Len := 0;
1279 Add_Str_To_Name_Buffer
1280 (Get_Name_String (Main_Project.Directory.Display_Name));
1281 Add_Str_To_Name_Buffer (Get_Name_String (Obj_Dir.Value));
1282 end if;
1283 end if;
1284
1285 Add_Char_To_Name_Buffer (Directory_Separator);
1286 Add_Str_To_Name_Buffer (Project_Tree.Source_Info_File_Name.all);
1287 Free (Project_Tree.Source_Info_File_Name);
1288 Project_Tree.Source_Info_File_Name :=
1289 new String'(Name_Buffer (1 .. Name_Len));
1290 end;
1291 end if;
1292
1293 Read_Source_Info_File (Project_Tree);
1294 end if;
1295
1296 -- Find configuration file
1297
1298 Get_Or_Create_Configuration_File
1299 (Config => Main_Config_Project,
1300 Project => Main_Project,
1301 Project_Tree => Project_Tree,
1302 Project_Node_Tree => Project_Node_Tree,
1303 Allow_Automatic_Generation => Allow_Automatic_Generation,
1304 Config_File_Name => Config_File_Name,
1305 Autoconf_Specified => Autoconf_Specified,
1306 Target_Name => Target_Name,
1307 Normalized_Hostname => Normalized_Hostname,
1308 Packages_To_Check => Packages_To_Check,
1309 Config_File_Path => Config_File_Path,
1310 Automatically_Generated => Automatically_Generated,
1311 Flags => Flags,
1312 On_Load_Config => On_Load_Config);
1313
1314 Apply_Config_File (Main_Config_Project, Project_Tree);
1315
1316 -- Finish processing the user's project
1317
1318 Prj.Proc.Process_Project_Tree_Phase_2
1319 (In_Tree => Project_Tree,
1320 Project => Main_Project,
1321 Success => Success,
1322 From_Project_Node => User_Project_Node,
1323 From_Project_Node_Tree => Project_Node_Tree,
1324 Flags => Flags);
1325
1326 if Success then
1327 if Project_Tree.Source_Info_File_Name /= null and then
1328 not Project_Tree.Source_Info_File_Exists
1329 then
1330 Write_Source_Info_File (Project_Tree);
1331 end if;
1332
1333 else
1334 Main_Project := No_Project;
1335 end if;
1336 end Process_Project_And_Apply_Config;
1337
1338 ----------------------
1339 -- Runtime_Name_For --
1340 ----------------------
1341
1342 function Runtime_Name_For (Language : Name_Id) return String is
1343 begin
1344 if RTS_Languages.Get (Language) /= No_Name then
1345 return Get_Name_String (RTS_Languages.Get (Language));
1346 else
1347 return "";
1348 end if;
1349 end Runtime_Name_For;
1350
1351 ---------------------
1352 -- Set_Runtime_For --
1353 ---------------------
1354
1355 procedure Set_Runtime_For (Language : Name_Id; RTS_Name : String) is
1356 begin
1357 Name_Len := RTS_Name'Length;
1358 Name_Buffer (1 .. Name_Len) := RTS_Name;
1359 RTS_Languages.Set (Language, Name_Find);
1360 end Set_Runtime_For;
1361
1362 end Prj.Conf;
GCC graphite test results