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