?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2014-10-17 Robert Dewar <dewar@adacore.com>
[official-gcc.git] / gcc / ada / prj-conf.adb
blob6d5cdc7cc15e546bf7393a879fd6e5750d8af9da
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-2014, 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 Makeutl; use Makeutl;
27 with MLib.Tgt;
28 with Opt; use Opt;
29 with Osint; use Osint;
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 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 Locate_Runtime
68 (Language : Name_Id;
69 Env : Prj.Tree.Environment);
70 -- If RTS_Name is a base name (a name without path separator), then
71 -- do nothing. Otherwise, convert it to an absolute path (possibly by
72 -- searching it in the project path) and call Set_Runtime_For with the
73 -- absolute path. Raise Invalid_Config if the path does not exist.
74
75 -----------------------
76 -- Local_Subprograms --
77 -----------------------
78
79 function Check_Target
80 (Config_File : Prj.Project_Id;
81 Autoconf_Specified : Boolean;
82 Project_Tree : Prj.Project_Tree_Ref;
83 Target : String := "") return Boolean;
84 -- Check that the config file's target matches Target.
85 -- Target should be set to the empty string when the user did not specify
86 -- a target. If the target in the configuration file is invalid, this
87 -- function will raise Invalid_Config with an appropriate message.
88 -- Autoconf_Specified should be set to True if the user has used
89 -- autoconf.
90
91 function Locate_Config_File (Name : String) return String_Access;
92 -- Search for Name in the config files directory. Return full path if
93 -- found, or null otherwise.
94
95 procedure Raise_Invalid_Config (Msg : String);
96 pragma No_Return (Raise_Invalid_Config);
97 -- Raises exception Invalid_Config with given message
98
99 procedure Apply_Config_File
100 (Config_File : Prj.Project_Id;
101 Project_Tree : Prj.Project_Tree_Ref);
102 -- Apply the configuration file settings to all the projects in the
103 -- project tree. The Project_Tree must have been parsed first, and
104 -- processed through the first phase so that all its projects are known.
105 --
106 -- Currently, this will add new attributes and packages in the various
107 -- projects, so that when the second phase of the processing is performed
108 -- these attributes are automatically taken into account.
109
110 ------------------------------------
111 -- Add_Default_GNAT_Naming_Scheme --
112 ------------------------------------
113
114 procedure Add_Default_GNAT_Naming_Scheme
115 (Config_File : in out Project_Node_Id;
116 Project_Tree : Project_Node_Tree_Ref)
117 is
118 procedure Create_Attribute
119 (Name : Name_Id;
120 Value : String;
121 Index : String := "";
122 Pkg : Project_Node_Id := Empty_Node);
123
124 ----------------------
125 -- Create_Attribute --
126 ----------------------
127
128 procedure Create_Attribute
129 (Name : Name_Id;
130 Value : String;
131 Index : String := "";
132 Pkg : Project_Node_Id := Empty_Node)
133 is
134 Attr : Project_Node_Id;
135 pragma Unreferenced (Attr);
136
137 Expr : Name_Id := No_Name;
138 Val : Name_Id := No_Name;
139 Parent : Project_Node_Id := Config_File;
140
141 begin
142 if Index /= "" then
143 Name_Len := Index'Length;
144 Name_Buffer (1 .. Name_Len) := Index;
145 Val := Name_Find;
146 end if;
147
148 if Pkg /= Empty_Node then
149 Parent := Pkg;
150 end if;
151
152 Name_Len := Value'Length;
153 Name_Buffer (1 .. Name_Len) := Value;
154 Expr := Name_Find;
155
156 Attr := Create_Attribute
157 (Tree => Project_Tree,
158 Prj_Or_Pkg => Parent,
159 Name => Name,
160 Index_Name => Val,
161 Kind => Prj.Single,
162 Value => Create_Literal_String (Expr, Project_Tree));
163 end Create_Attribute;
164
165 -- Local variables
166
167 Name : Name_Id;
168 Naming : Project_Node_Id;
169 Compiler : Project_Node_Id;
170
171 -- Start of processing for Add_Default_GNAT_Naming_Scheme
172
173 begin
174 if Config_File = Empty_Node then
175
176 -- Create a dummy config file if none was found
177
178 Name_Len := Auto_Cgpr'Length;
179 Name_Buffer (1 .. Name_Len) := Auto_Cgpr;
180 Name := Name_Find;
181
182 -- An invalid project name to avoid conflicts with user-created ones
183
184 Name_Len := 5;
185 Name_Buffer (1 .. Name_Len) := "_auto";
186
187 Config_File :=
188 Create_Project
189 (In_Tree => Project_Tree,
190 Name => Name_Find,
191 Full_Path => Path_Name_Type (Name),
192 Is_Config_File => True);
193
194 -- Setup library support
195
196 case MLib.Tgt.Support_For_Libraries is
197 when None =>
198 null;
199
200 when Static_Only =>
201 Create_Attribute (Name_Library_Support, "static_only");
202
203 when Full =>
204 Create_Attribute (Name_Library_Support, "full");
205 end case;
206
207 if MLib.Tgt.Standalone_Library_Auto_Init_Is_Supported then
208 Create_Attribute (Name_Library_Auto_Init_Supported, "true");
209 else
210 Create_Attribute (Name_Library_Auto_Init_Supported, "false");
211 end if;
212
213 -- Declare an empty target
214
215 Create_Attribute (Name_Target, "");
216
217 -- Setup Ada support (Ada is the default language here, since this
218 -- is only called when no config file existed initially, ie for
219 -- gnatmake).
220
221 Create_Attribute (Name_Default_Language, "ada");
222
223 Compiler := Create_Package (Project_Tree, Config_File, "compiler");
224 Create_Attribute
225 (Name_Driver, "gcc", "ada", Pkg => Compiler);
226 Create_Attribute
227 (Name_Language_Kind, "unit_based", "ada", Pkg => Compiler);
228 Create_Attribute
229 (Name_Dependency_Kind, "ALI_File", "ada", Pkg => Compiler);
230
231 Naming := Create_Package (Project_Tree, Config_File, "naming");
232 Create_Attribute (Name_Spec_Suffix, ".ads", "ada", Pkg => Naming);
233 Create_Attribute (Name_Separate_Suffix, ".adb", "ada", Pkg => Naming);
234 Create_Attribute (Name_Body_Suffix, ".adb", "ada", Pkg => Naming);
235 Create_Attribute (Name_Dot_Replacement, "-", Pkg => Naming);
236 Create_Attribute (Name_Casing, "lowercase", Pkg => Naming);
237
238 if Current_Verbosity = High then
239 Write_Line ("Automatically generated (in-memory) config file");
240 Prj.PP.Pretty_Print
241 (Project => Config_File,
242 In_Tree => Project_Tree,
243 Backward_Compatibility => False);
244 end if;
245 end if;
246 end Add_Default_GNAT_Naming_Scheme;
247
248 -----------------------
249 -- Apply_Config_File --
250 -----------------------
251
252 procedure Apply_Config_File
253 (Config_File : Prj.Project_Id;
254 Project_Tree : Prj.Project_Tree_Ref)
255 is
256 procedure Add_Attributes
257 (Project_Tree : Project_Tree_Ref;
258 Conf_Decl : Declarations;
259 User_Decl : in out Declarations);
260 -- Process the attributes in the config declarations. For
261 -- single string values, if the attribute is not declared in
262 -- the user declarations, declare it with the value in the
263 -- config declarations. For string list values, prepend the
264 -- value in the user declarations with the value in the config
265 -- declarations.
266
267 --------------------
268 -- Add_Attributes --
269 --------------------
270
271 procedure Add_Attributes
272 (Project_Tree : Project_Tree_Ref;
273 Conf_Decl : Declarations;
274 User_Decl : in out Declarations)
275 is
276 Shared : constant Shared_Project_Tree_Data_Access :=
277 Project_Tree.Shared;
278 Conf_Attr_Id : Variable_Id;
279 Conf_Attr : Variable;
280 Conf_Array_Id : Array_Id;
281 Conf_Array : Array_Data;
282 Conf_Array_Elem_Id : Array_Element_Id;
283 Conf_Array_Elem : Array_Element;
284 Conf_List : String_List_Id;
285 Conf_List_Elem : String_Element;
286
287 User_Attr_Id : Variable_Id;
288 User_Attr : Variable;
289 User_Array_Id : Array_Id;
290 User_Array : Array_Data;
291 User_Array_Elem_Id : Array_Element_Id;
292 User_Array_Elem : Array_Element;
293
294 begin
295 Conf_Attr_Id := Conf_Decl.Attributes;
296 User_Attr_Id := User_Decl.Attributes;
297
298 while Conf_Attr_Id /= No_Variable loop
299 Conf_Attr := Shared.Variable_Elements.Table (Conf_Attr_Id);
300 User_Attr := Shared.Variable_Elements.Table (User_Attr_Id);
301
302 if not Conf_Attr.Value.Default then
303 if User_Attr.Value.Default then
304
305 -- No attribute declared in user project file: just copy
306 -- the value of the configuration attribute.
307
308 User_Attr.Value := Conf_Attr.Value;
309 Shared.Variable_Elements.Table (User_Attr_Id) := User_Attr;
310
311 elsif User_Attr.Value.Kind = List
312 and then Conf_Attr.Value.Values /= Nil_String
313 then
314 -- List attribute declared in both the user project and the
315 -- configuration project: prepend the user list with the
316 -- configuration list.
317
318 declare
319 User_List : constant String_List_Id :=
320 User_Attr.Value.Values;
321 Conf_List : String_List_Id := Conf_Attr.Value.Values;
322 Conf_Elem : String_Element;
323 New_List : String_List_Id;
324 New_Elem : String_Element;
325
326 begin
327 -- Create new list
328
329 String_Element_Table.Increment_Last
330 (Shared.String_Elements);
331 New_List :=
332 String_Element_Table.Last (Shared.String_Elements);
333
334 -- Value of attribute is new list
335
336 User_Attr.Value.Values := New_List;
337 Shared.Variable_Elements.Table (User_Attr_Id) :=
338 User_Attr;
339
340 loop
341 -- Get each element of configuration list
342
343 Conf_Elem := Shared.String_Elements.Table (Conf_List);
344 New_Elem := Conf_Elem;
345 Conf_List := Conf_Elem.Next;
346
347 if Conf_List = Nil_String then
348
349 -- If it is the last element in the list, connect
350 -- to first element of user list, and we are done.
351
352 New_Elem.Next := User_List;
353 Shared.String_Elements.Table (New_List) := New_Elem;
354 exit;
355
356 else
357 -- If it is not the last element in the list, add
358 -- to new list.
359
360 String_Element_Table.Increment_Last
361 (Shared.String_Elements);
362 New_Elem.Next := String_Element_Table.Last
363 (Shared.String_Elements);
364 Shared.String_Elements.Table (New_List) := New_Elem;
365 New_List := New_Elem.Next;
366 end if;
367 end loop;
368 end;
369 end if;
370 end if;
371
372 Conf_Attr_Id := Conf_Attr.Next;
373 User_Attr_Id := User_Attr.Next;
374 end loop;
375
376 Conf_Array_Id := Conf_Decl.Arrays;
377 while Conf_Array_Id /= No_Array loop
378 Conf_Array := Shared.Arrays.Table (Conf_Array_Id);
379
380 User_Array_Id := User_Decl.Arrays;
381 while User_Array_Id /= No_Array loop
382 User_Array := Shared.Arrays.Table (User_Array_Id);
383 exit when User_Array.Name = Conf_Array.Name;
384 User_Array_Id := User_Array.Next;
385 end loop;
386
387 -- If this associative array does not exist in the user project
388 -- file, do a shallow copy of the full associative array.
389
390 if User_Array_Id = No_Array then
391 Array_Table.Increment_Last (Shared.Arrays);
392 User_Array := Conf_Array;
393 User_Array.Next := User_Decl.Arrays;
394 User_Decl.Arrays := Array_Table.Last (Shared.Arrays);
395 Shared.Arrays.Table (User_Decl.Arrays) := User_Array;
396
397 -- Otherwise, check each array element
398
399 else
400 Conf_Array_Elem_Id := Conf_Array.Value;
401 while Conf_Array_Elem_Id /= No_Array_Element loop
402 Conf_Array_Elem :=
403 Shared.Array_Elements.Table (Conf_Array_Elem_Id);
404
405 User_Array_Elem_Id := User_Array.Value;
406 while User_Array_Elem_Id /= No_Array_Element loop
407 User_Array_Elem :=
408 Shared.Array_Elements.Table (User_Array_Elem_Id);
409 exit when User_Array_Elem.Index = Conf_Array_Elem.Index;
410 User_Array_Elem_Id := User_Array_Elem.Next;
411 end loop;
412
413 -- If the array element doesn't exist in the user array,
414 -- insert a shallow copy of the conf array element in the
415 -- user array.
416
417 if User_Array_Elem_Id = No_Array_Element then
418 Array_Element_Table.Increment_Last
419 (Shared.Array_Elements);
420 User_Array_Elem := Conf_Array_Elem;
421 User_Array_Elem.Next := User_Array.Value;
422 User_Array.Value :=
423 Array_Element_Table.Last (Shared.Array_Elements);
424 Shared.Array_Elements.Table (User_Array.Value) :=
425 User_Array_Elem;
426 Shared.Arrays.Table (User_Array_Id) := User_Array;
427
428 -- Otherwise, if the value is a string list, prepend the
429 -- conf array element value to the array element.
430
431 elsif Conf_Array_Elem.Value.Kind = List then
432 Conf_List := Conf_Array_Elem.Value.Values;
433
434 if Conf_List /= Nil_String then
435 declare
436 Link : constant String_List_Id :=
437 User_Array_Elem.Value.Values;
438 Previous : String_List_Id := Nil_String;
439 Next : String_List_Id;
440
441 begin
442 loop
443 Conf_List_Elem :=
444 Shared.String_Elements.Table (Conf_List);
445 String_Element_Table.Increment_Last
446 (Shared.String_Elements);
447 Next :=
448 String_Element_Table.Last
449 (Shared.String_Elements);
450 Shared.String_Elements.Table (Next) :=
451 Conf_List_Elem;
452
453 if Previous = Nil_String then
454 User_Array_Elem.Value.Values := Next;
455 Shared.Array_Elements.Table
456 (User_Array_Elem_Id) := User_Array_Elem;
457
458 else
459 Shared.String_Elements.Table
460 (Previous).Next := Next;
461 end if;
462
463 Previous := Next;
464
465 Conf_List := Conf_List_Elem.Next;
466
467 if Conf_List = Nil_String then
468 Shared.String_Elements.Table
469 (Previous).Next := Link;
470 exit;
471 end if;
472 end loop;
473 end;
474 end if;
475 end if;
476
477 Conf_Array_Elem_Id := Conf_Array_Elem.Next;
478 end loop;
479 end if;
480
481 Conf_Array_Id := Conf_Array.Next;
482 end loop;
483 end Add_Attributes;
484
485 Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared;
486
487 Conf_Decl : constant Declarations := Config_File.Decl;
488 Conf_Pack_Id : Package_Id;
489 Conf_Pack : Package_Element;
490
491 User_Decl : Declarations;
492 User_Pack_Id : Package_Id;
493 User_Pack : Package_Element;
494 Proj : Project_List;
495
496 begin
497 Debug_Output ("Applying config file to a project tree");
498
499 Proj := Project_Tree.Projects;
500 while Proj /= null loop
501 if Proj.Project /= Config_File then
502 User_Decl := Proj.Project.Decl;
503 Add_Attributes
504 (Project_Tree => Project_Tree,
505 Conf_Decl => Conf_Decl,
506 User_Decl => User_Decl);
507
508 Conf_Pack_Id := Conf_Decl.Packages;
509 while Conf_Pack_Id /= No_Package loop
510 Conf_Pack := Shared.Packages.Table (Conf_Pack_Id);
511
512 User_Pack_Id := User_Decl.Packages;
513 while User_Pack_Id /= No_Package loop
514 User_Pack := Shared.Packages.Table (User_Pack_Id);
515 exit when User_Pack.Name = Conf_Pack.Name;
516 User_Pack_Id := User_Pack.Next;
517 end loop;
518
519 if User_Pack_Id = No_Package then
520 Package_Table.Increment_Last (Shared.Packages);
521 User_Pack := Conf_Pack;
522 User_Pack.Next := User_Decl.Packages;
523 User_Decl.Packages := Package_Table.Last (Shared.Packages);
524 Shared.Packages.Table (User_Decl.Packages) := User_Pack;
525
526 else
527 Add_Attributes
528 (Project_Tree => Project_Tree,
529 Conf_Decl => Conf_Pack.Decl,
530 User_Decl => Shared.Packages.Table
531 (User_Pack_Id).Decl);
532 end if;
533
534 Conf_Pack_Id := Conf_Pack.Next;
535 end loop;
536
537 Proj.Project.Decl := User_Decl;
538
539 -- For aggregate projects, we need to apply the config to all
540 -- their aggregated trees as well.
541
542 if Proj.Project.Qualifier in Aggregate_Project then
543 declare
544 List : Aggregated_Project_List;
545 begin
546 List := Proj.Project.Aggregated_Projects;
547 while List /= null loop
548 Debug_Output
549 ("Recursively apply config to aggregated tree",
550 List.Project.Name);
551 Apply_Config_File
552 (Config_File, Project_Tree => List.Tree);
553 List := List.Next;
554 end loop;
555 end;
556 end if;
557 end if;
558
559 Proj := Proj.Next;
560 end loop;
561 end Apply_Config_File;
562
563 ------------------
564 -- Check_Target --
565 ------------------
566
567 function Check_Target
568 (Config_File : Project_Id;
569 Autoconf_Specified : Boolean;
570 Project_Tree : Prj.Project_Tree_Ref;
571 Target : String := "") return Boolean
572 is
573 Shared : constant Shared_Project_Tree_Data_Access :=
574 Project_Tree.Shared;
575 Variable : constant Variable_Value :=
576 Value_Of
577 (Name_Target, Config_File.Decl.Attributes, Shared);
578 Tgt_Name : Name_Id := No_Name;
579 OK : Boolean;
580
581 begin
582 if Variable /= Nil_Variable_Value and then not Variable.Default then
583 Tgt_Name := Variable.Value;
584 end if;
585
586 OK :=
587 Target = ""
588 or else
589 (Tgt_Name /= No_Name
590 and then (Length_Of_Name (Tgt_Name) = 0
591 or else Target = Get_Name_String (Tgt_Name)));
592
593 if not OK then
594 if Autoconf_Specified then
595 if Verbose_Mode then
596 Write_Line ("inconsistent targets, performing autoconf");
597 end if;
598
599 return False;
600
601 else
602 if Tgt_Name /= No_Name then
603 Raise_Invalid_Config
604 ("invalid target name """
605 & Get_Name_String (Tgt_Name) & """ in configuration");
606 else
607 Raise_Invalid_Config
608 ("no target specified in configuration file");
609 end if;
610 end if;
611 end if;
612
613 return True;
614 end Check_Target;
615
616 --------------------------------------
617 -- Get_Or_Create_Configuration_File --
618 --------------------------------------
619
620 procedure Get_Or_Create_Configuration_File
621 (Project : Project_Id;
622 Conf_Project : Project_Id;
623 Project_Tree : Project_Tree_Ref;
624 Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
625 Env : in out Prj.Tree.Environment;
626 Allow_Automatic_Generation : Boolean;
627 Config_File_Name : String := "";
628 Autoconf_Specified : Boolean;
629 Target_Name : String := "";
630 Normalized_Hostname : String;
631 Packages_To_Check : String_List_Access := null;
632 Config : out Prj.Project_Id;
633 Config_File_Path : out String_Access;
634 Automatically_Generated : out Boolean;
635 On_Load_Config : Config_File_Hook := null)
636 is
637 Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared;
638
639 At_Least_One_Compiler_Command : Boolean := False;
640 -- Set to True if at least one attribute Ide'Compiler_Command is
641 -- specified for one language of the system.
642
643 Conf_File_Name : String_Access := new String'(Config_File_Name);
644 -- The configuration project file name. May be modified if there are
645 -- switches --config= in the Builder package of the main project.
646
647 Selected_Target : String_Access := new String'(Target_Name);
648
649 function Default_File_Name return String;
650 -- Return the name of the default config file that should be tested
651
652 procedure Do_Autoconf;
653 -- Generate a new config file through gprconfig. In case of error, this
654 -- raises the Invalid_Config exception with an appropriate message
655
656 procedure Check_Builder_Switches;
657 -- Check for switches --config and --RTS in package Builder
658
659 procedure Get_Project_Target;
660 -- If Target_Name is empty, get the specified target in the project
661 -- file, if any.
662
663 function Get_Config_Switches return Argument_List_Access;
664 -- Return the --config switches to use for gprconfig
665
666 function Get_Db_Switches return Argument_List_Access;
667 -- Return the --db switches to use for gprconfig
668
669 function Might_Have_Sources (Project : Project_Id) return Boolean;
670 -- True if the specified project might have sources (ie the user has not
671 -- explicitly specified it. We haven't checked the file system, nor do
672 -- we need to at this stage.
673
674 ----------------------------
675 -- Check_Builder_Switches --
676 ----------------------------
677
678 procedure Check_Builder_Switches is
679 Get_RTS_Switches : constant Boolean :=
680 RTS_Languages.Get_First = No_Name;
681 -- If no switch --RTS have been specified on the command line, look
682 -- for --RTS switches in the Builder switches.
683
684 Builder : constant Package_Id :=
685 Value_Of (Name_Builder, Project.Decl.Packages, Shared);
686
687 Switch_Array_Id : Array_Element_Id;
688 -- The Switches to be checked
689
690 procedure Check_Switches;
691 -- Check the switches in Switch_Array_Id
692
693 --------------------
694 -- Check_Switches --
695 --------------------
696
697 procedure Check_Switches is
698 Switch_Array : Array_Element;
699 Switch_List : String_List_Id := Nil_String;
700 Switch : String_Element;
701 Lang : Name_Id;
702 Lang_Last : Positive;
703
704 begin
705 while Switch_Array_Id /= No_Array_Element loop
706 Switch_Array :=
707 Shared.Array_Elements.Table (Switch_Array_Id);
708
709 Switch_List := Switch_Array.Value.Values;
710 List_Loop : while Switch_List /= Nil_String loop
711 Switch := Shared.String_Elements.Table (Switch_List);
712
713 if Switch.Value /= No_Name then
714 Get_Name_String (Switch.Value);
715
716 if Conf_File_Name'Length = 0
717 and then Name_Len > 9
718 and then Name_Buffer (1 .. 9) = "--config="
719 then
720 Conf_File_Name :=
721 new String'(Name_Buffer (10 .. Name_Len));
722
723 elsif Get_RTS_Switches
724 and then Name_Len >= 7
725 and then Name_Buffer (1 .. 5) = "--RTS"
726 then
727 if Name_Buffer (6) = '=' then
728 if not Runtime_Name_Set_For (Name_Ada) then
729 Set_Runtime_For
730 (Name_Ada,
731 Name_Buffer (7 .. Name_Len));
732 Locate_Runtime (Name_Ada, Env);
733 end if;
734
735 elsif Name_Len > 7
736 and then Name_Buffer (6) = ':'
737 and then Name_Buffer (7) /= '='
738 then
739 Lang_Last := 7;
740 while Lang_Last < Name_Len
741 and then Name_Buffer (Lang_Last + 1) /= '='
742 loop
743 Lang_Last := Lang_Last + 1;
744 end loop;
745
746 if Name_Buffer (Lang_Last + 1) = '=' then
747 declare
748 RTS : constant String :=
749 Name_Buffer (Lang_Last + 2 .. Name_Len);
750 begin
751 Name_Buffer (1 .. Lang_Last - 6) :=
752 Name_Buffer (7 .. Lang_Last);
753 Name_Len := Lang_Last - 6;
754 To_Lower (Name_Buffer (1 .. Name_Len));
755 Lang := Name_Find;
756
757 if not Runtime_Name_Set_For (Lang) then
758 Set_Runtime_For (Lang, RTS);
759 Locate_Runtime (Lang, Env);
760 end if;
761 end;
762 end if;
763 end if;
764 end if;
765 end if;
766
767 Switch_List := Switch.Next;
768 end loop List_Loop;
769
770 Switch_Array_Id := Switch_Array.Next;
771 end loop;
772 end Check_Switches;
773
774 -- Start of processing for Check_Builder_Switches
775
776 begin
777 if Builder /= No_Package then
778 Switch_Array_Id :=
779 Value_Of
780 (Name => Name_Switches,
781 In_Arrays => Shared.Packages.Table (Builder).Decl.Arrays,
782 Shared => Shared);
783 Check_Switches;
784
785 Switch_Array_Id :=
786 Value_Of
787 (Name => Name_Default_Switches,
788 In_Arrays => Shared.Packages.Table (Builder).Decl.Arrays,
789 Shared => Shared);
790 Check_Switches;
791 end if;
792 end Check_Builder_Switches;
793
794 ------------------------
795 -- Get_Project_Target --
796 ------------------------
797
798 procedure Get_Project_Target is
799 begin
800 if Selected_Target'Length = 0 then
801
802 -- Check if attribute Target is specified in the main
803 -- project, or in a project it extends. If it is, use this
804 -- target to invoke gprconfig.
805
806 declare
807 Variable : Variable_Value;
808 Proj : Project_Id;
809 Tgt_Name : Name_Id := No_Name;
810
811 begin
812 Proj := Project;
813 Project_Loop :
814 while Proj /= No_Project loop
815 Variable :=
816 Value_Of (Name_Target, Proj.Decl.Attributes, Shared);
817
818 if Variable /= Nil_Variable_Value
819 and then not Variable.Default
820 and then Variable.Value /= No_Name
821 then
822 Tgt_Name := Variable.Value;
823 exit Project_Loop;
824 end if;
825
826 Proj := Proj.Extends;
827 end loop Project_Loop;
828
829 if Tgt_Name /= No_Name then
830 Selected_Target := new String'(Get_Name_String (Tgt_Name));
831 end if;
832 end;
833 end if;
834 end Get_Project_Target;
835
836 -----------------------
837 -- Default_File_Name --
838 -----------------------
839
840 function Default_File_Name return String is
841 Ada_RTS : constant String := Runtime_Name_For (Name_Ada);
842 Tmp : String_Access;
843
844 begin
845 if Selected_Target'Length /= 0 then
846 if Ada_RTS /= "" then
847 return
848 Selected_Target.all & '-' &
849 Ada_RTS & Config_Project_File_Extension;
850 else
851 return
852 Selected_Target.all & Config_Project_File_Extension;
853 end if;
854
855 elsif Ada_RTS /= "" then
856 return Ada_RTS & Config_Project_File_Extension;
857
858 else
859 Tmp := Getenv (Config_Project_Env_Var);
860
861 declare
862 T : constant String := Tmp.all;
863
864 begin
865 Free (Tmp);
866
867 if T'Length = 0 then
868 return Default_Config_Name;
869 else
870 return T;
871 end if;
872 end;
873 end if;
874 end Default_File_Name;
875
876 -----------------
877 -- Do_Autoconf --
878 -----------------
879
880 procedure Do_Autoconf is
881 Obj_Dir : constant Variable_Value :=
882 Value_Of
883 (Name_Object_Dir,
884 Conf_Project.Decl.Attributes,
885 Shared);
886
887 Gprconfig_Path : String_Access;
888 Success : Boolean;
889
890 begin
891 Gprconfig_Path := Locate_Exec_On_Path (Gprconfig_Name);
892
893 if Gprconfig_Path = null then
894 Raise_Invalid_Config
895 ("could not locate gprconfig for auto-configuration");
896 end if;
897
898 -- First, find the object directory of the Conf_Project
899
900 if Obj_Dir = Nil_Variable_Value or else Obj_Dir.Default then
901 Get_Name_String (Conf_Project.Directory.Display_Name);
902
903 else
904 if Is_Absolute_Path (Get_Name_String (Obj_Dir.Value)) then
905 Get_Name_String (Obj_Dir.Value);
906
907 else
908 Name_Len := 0;
909 Add_Str_To_Name_Buffer
910 (Get_Name_String (Conf_Project.Directory.Display_Name));
911 Add_Str_To_Name_Buffer (Get_Name_String (Obj_Dir.Value));
912 end if;
913 end if;
914
915 if Subdirs /= null then
916 Add_Char_To_Name_Buffer (Directory_Separator);
917 Add_Str_To_Name_Buffer (Subdirs.all);
918 end if;
919
920 for J in 1 .. Name_Len loop
921 if Name_Buffer (J) = '/' then
922 Name_Buffer (J) := Directory_Separator;
923 end if;
924 end loop;
925
926 -- Make sure that Obj_Dir ends with a directory separator
927
928 if Name_Buffer (Name_Len) /= Directory_Separator then
929 Name_Len := Name_Len + 1;
930 Name_Buffer (Name_Len) := Directory_Separator;
931 end if;
932
933 declare
934 Obj_Dir : constant String := Name_Buffer (1 .. Name_Len);
935 Config_Switches : Argument_List_Access;
936 Db_Switches : Argument_List_Access;
937 Args : Argument_List (1 .. 5);
938 Arg_Last : Positive;
939 Obj_Dir_Exists : Boolean := True;
940
941 begin
942 -- Check if the object directory exists. If Setup_Projects is True
943 -- (-p) and directory does not exist, attempt to create it.
944 -- Otherwise, if directory does not exist, fail without calling
945 -- gprconfig.
946
947 if not Is_Directory (Obj_Dir)
948 and then (Setup_Projects or else Subdirs /= null)
949 then
950 begin
951 Create_Path (Obj_Dir);
952
953 if not Quiet_Output then
954 Write_Str ("object directory """);
955 Write_Str (Obj_Dir);
956 Write_Line (""" created");
957 end if;
958
959 exception
960 when others =>
961 Raise_Invalid_Config
962 ("could not create object directory " & Obj_Dir);
963 end;
964 end if;
965
966 if not Is_Directory (Obj_Dir) then
967 case Env.Flags.Require_Obj_Dirs is
968 when Error =>
969 Raise_Invalid_Config
970 ("object directory " & Obj_Dir & " does not exist");
971
972 when Warning =>
973 Prj.Err.Error_Msg
974 (Env.Flags,
975 "?object directory " & Obj_Dir & " does not exist");
976 Obj_Dir_Exists := False;
977
978 when Silent =>
979 null;
980 end case;
981 end if;
982
983 -- Get the config switches. This should be done only now, as some
984 -- runtimes may have been found in the Builder switches.
985
986 Config_Switches := Get_Config_Switches;
987
988 -- Get eventual --db switches
989
990 Db_Switches := Get_Db_Switches;
991
992 -- Invoke gprconfig
993
994 Args (1) := new String'("--batch");
995 Args (2) := new String'("-o");
996
997 -- If no config file was specified, set the auto.cgpr one
998
999 if Conf_File_Name'Length = 0 then
1000 if Obj_Dir_Exists then
1001 Args (3) := new String'(Obj_Dir & Auto_Cgpr);
1002
1003 else
1004 declare
1005 Path_FD : File_Descriptor;
1006 Path_Name : Path_Name_Type;
1007
1008 begin
1009 Prj.Env.Create_Temp_File
1010 (Shared => Project_Tree.Shared,
1011 Path_FD => Path_FD,
1012 Path_Name => Path_Name,
1013 File_Use => "configuration file");
1014
1015 if Path_FD /= Invalid_FD then
1016 declare
1017 Temp_Dir : constant String :=
1018 Containing_Directory
1019 (Get_Name_String (Path_Name));
1020 begin
1021 GNAT.OS_Lib.Close (Path_FD);
1022 Args (3) :=
1023 new String'(Temp_Dir &
1024 Directory_Separator &
1025 Auto_Cgpr);
1026 Delete_File (Get_Name_String (Path_Name));
1027 end;
1028
1029 else
1030 -- We'll have an error message later on
1031
1032 Args (3) := new String'(Obj_Dir & Auto_Cgpr);
1033 end if;
1034 end;
1035 end if;
1036 else
1037 Args (3) := Conf_File_Name;
1038 end if;
1039
1040 if Normalized_Hostname = "" then
1041 Arg_Last := 3;
1042 else
1043 if Selected_Target'Length = 0 then
1044 if At_Least_One_Compiler_Command then
1045 Args (4) :=
1046 new String'("--target=all");
1047 else
1048 Args (4) :=
1049 new String'("--target=" & Normalized_Hostname);
1050 end if;
1051
1052 else
1053 Args (4) :=
1054 new String'("--target=" & Selected_Target.all);
1055 end if;
1056
1057 Arg_Last := 4;
1058 end if;
1059
1060 if not Verbose_Mode then
1061 Arg_Last := Arg_Last + 1;
1062 Args (Arg_Last) := new String'("-q");
1063 end if;
1064
1065 if Verbose_Mode then
1066 Write_Str (Gprconfig_Name);
1067
1068 for J in 1 .. Arg_Last loop
1069 Write_Char (' ');
1070 Write_Str (Args (J).all);
1071 end loop;
1072
1073 for J in Config_Switches'Range loop
1074 Write_Char (' ');
1075 Write_Str (Config_Switches (J).all);
1076 end loop;
1077
1078 for J in Db_Switches'Range loop
1079 Write_Char (' ');
1080 Write_Str (Db_Switches (J).all);
1081 end loop;
1082
1083 Write_Eol;
1084
1085 elsif not Quiet_Output then
1086
1087 -- Display no message if we are creating auto.cgpr, unless in
1088 -- verbose mode.
1089
1090 if Config_File_Name'Length > 0 or else Verbose_Mode then
1091 Write_Str ("creating ");
1092 Write_Str (Simple_Name (Args (3).all));
1093 Write_Eol;
1094 end if;
1095 end if;
1096
1097 Spawn (Gprconfig_Path.all, Args (1 .. Arg_Last) &
1098 Config_Switches.all & Db_Switches.all,
1099 Success);
1100
1101 Free (Config_Switches);
1102
1103 Config_File_Path := Locate_Config_File (Args (3).all);
1104
1105 if Config_File_Path = null then
1106 Raise_Invalid_Config
1107 ("could not create " & Args (3).all);
1108 end if;
1109
1110 for F in Args'Range loop
1111 Free (Args (F));
1112 end loop;
1113 end;
1114 end Do_Autoconf;
1115
1116 ---------------------
1117 -- Get_Db_Switches --
1118 ---------------------
1119
1120 function Get_Db_Switches return Argument_List_Access is
1121 Result : Argument_List_Access;
1122 Nmb_Arg : Natural;
1123 begin
1124 Nmb_Arg :=
1125 (2 * Db_Switch_Args.Last) + Boolean'Pos (not Load_Standard_Base);
1126 Result := new Argument_List (1 .. Nmb_Arg);
1127
1128 if Nmb_Arg /= 0 then
1129 for J in 1 .. Db_Switch_Args.Last loop
1130 Result (2 * J - 1) :=
1131 new String'("--db");
1132 Result (2 * J) :=
1133 new String'(Get_Name_String (Db_Switch_Args.Table (J)));
1134 end loop;
1135
1136 if not Load_Standard_Base then
1137 Result (Result'Last) := new String'("--db-");
1138 end if;
1139 end if;
1140
1141 return Result;
1142 end Get_Db_Switches;
1143
1144 -------------------------
1145 -- Get_Config_Switches --
1146 -------------------------
1147
1148 function Get_Config_Switches return Argument_List_Access is
1149
1150 package Language_Htable is new GNAT.HTable.Simple_HTable
1151 (Header_Num => Prj.Header_Num,
1152 Element => Name_Id,
1153 No_Element => No_Name,
1154 Key => Name_Id,
1155 Hash => Prj.Hash,
1156 Equal => "=");
1157 -- Hash table to keep the languages used in the project tree
1158
1159 IDE : constant Package_Id :=
1160 Value_Of (Name_Ide, Project.Decl.Packages, Shared);
1161
1162 procedure Add_Config_Switches_For_Project
1163 (Project : Project_Id;
1164 Tree : Project_Tree_Ref;
1165 With_State : in out Integer);
1166 -- Add all --config switches for this project. This is also called
1167 -- for aggregate projects.
1168
1169 -------------------------------------
1170 -- Add_Config_Switches_For_Project --
1171 -------------------------------------
1172
1173 procedure Add_Config_Switches_For_Project
1174 (Project : Project_Id;
1175 Tree : Project_Tree_Ref;
1176 With_State : in out Integer)
1177 is
1178 pragma Unreferenced (With_State);
1179
1180 Shared : constant Shared_Project_Tree_Data_Access := Tree.Shared;
1181
1182 Variable : Variable_Value;
1183 Check_Default : Boolean;
1184 Lang : Name_Id;
1185 List : String_List_Id;
1186 Elem : String_Element;
1187
1188 begin
1189 if Might_Have_Sources (Project) then
1190 Variable :=
1191 Value_Of (Name_Languages, Project.Decl.Attributes, Shared);
1192
1193 if Variable = Nil_Variable_Value or else Variable.Default then
1194
1195 -- Languages is not declared. If it is not an extending
1196 -- project, or if it extends a project with no Languages,
1197 -- check for Default_Language.
1198
1199 Check_Default := Project.Extends = No_Project;
1200
1201 if not Check_Default then
1202 Variable :=
1203 Value_Of
1204 (Name_Languages,
1205 Project.Extends.Decl.Attributes,
1206 Shared);
1207 Check_Default :=
1208 Variable /= Nil_Variable_Value
1209 and then Variable.Values = Nil_String;
1210 end if;
1211
1212 if Check_Default then
1213 Variable :=
1214 Value_Of
1215 (Name_Default_Language,
1216 Project.Decl.Attributes,
1217 Shared);
1218
1219 if Variable /= Nil_Variable_Value
1220 and then not Variable.Default
1221 then
1222 Get_Name_String (Variable.Value);
1223 To_Lower (Name_Buffer (1 .. Name_Len));
1224 Lang := Name_Find;
1225 Language_Htable.Set (Lang, Lang);
1226
1227 -- If no default language is declared, default to Ada
1228
1229 else
1230 Language_Htable.Set (Name_Ada, Name_Ada);
1231 end if;
1232 end if;
1233
1234 elsif Variable.Values /= Nil_String then
1235
1236 -- Attribute Languages is declared with a non empty list:
1237 -- put all the languages in Language_HTable.
1238
1239 List := Variable.Values;
1240 while List /= Nil_String loop
1241 Elem := Shared.String_Elements.Table (List);
1242
1243 Get_Name_String (Elem.Value);
1244 To_Lower (Name_Buffer (1 .. Name_Len));
1245 Lang := Name_Find;
1246 Language_Htable.Set (Lang, Lang);
1247
1248 List := Elem.Next;
1249 end loop;
1250 end if;
1251 end if;
1252 end Add_Config_Switches_For_Project;
1253
1254 procedure For_Every_Imported_Project is new For_Every_Project_Imported
1255 (State => Integer, Action => Add_Config_Switches_For_Project);
1256 -- Document this procedure ???
1257
1258 -- Local variables
1259
1260 Name : Name_Id;
1261 Count : Natural;
1262 Result : Argument_List_Access;
1263 Variable : Variable_Value;
1264 Dummy : Integer := 0;
1265
1266 -- Start of processing for Get_Config_Switches
1267
1268 begin
1269 For_Every_Imported_Project
1270 (By => Project,
1271 Tree => Project_Tree,
1272 With_State => Dummy,
1273 Include_Aggregated => True);
1274
1275 Name := Language_Htable.Get_First;
1276 Count := 0;
1277 while Name /= No_Name loop
1278 Count := Count + 1;
1279 Name := Language_Htable.Get_Next;
1280 end loop;
1281
1282 Result := new String_List (1 .. Count);
1283
1284 Count := 1;
1285 Name := Language_Htable.Get_First;
1286 while Name /= No_Name loop
1287
1288 -- Check if IDE'Compiler_Command is declared for the language.
1289 -- If it is, use its value to invoke gprconfig.
1290
1291 Variable :=
1292 Value_Of
1293 (Name,
1294 Attribute_Or_Array_Name => Name_Compiler_Command,
1295 In_Package => IDE,
1296 Shared => Shared,
1297 Force_Lower_Case_Index => True);
1298
1299 declare
1300 Config_Command : constant String :=
1301 "--config=" & Get_Name_String (Name);
1302
1303 Runtime_Name : constant String := Runtime_Name_For (Name);
1304
1305 begin
1306 -- In CodePeer mode, we do not take into account any compiler
1307 -- command from the package IDE.
1308
1309 if CodePeer_Mode
1310 or else Variable = Nil_Variable_Value
1311 or else Length_Of_Name (Variable.Value) = 0
1312 then
1313 Result (Count) :=
1314 new String'(Config_Command & ",," & Runtime_Name);
1315
1316 else
1317 At_Least_One_Compiler_Command := True;
1318
1319 declare
1320 Compiler_Command : constant String :=
1321 Get_Name_String (Variable.Value);
1322
1323 begin
1324 if Is_Absolute_Path (Compiler_Command) then
1325 Result (Count) :=
1326 new String'
1327 (Config_Command & ",," & Runtime_Name & ","
1328 & Containing_Directory (Compiler_Command) & ","
1329 & Simple_Name (Compiler_Command));
1330 else
1331 Result (Count) :=
1332 new String'
1333 (Config_Command & ",," & Runtime_Name & ",,"
1334 & Compiler_Command);
1335 end if;
1336 end;
1337 end if;
1338 end;
1339
1340 Count := Count + 1;
1341 Name := Language_Htable.Get_Next;
1342 end loop;
1343
1344 return Result;
1345 end Get_Config_Switches;
1346
1347 ------------------------
1348 -- Might_Have_Sources --
1349 ------------------------
1350
1351 function Might_Have_Sources (Project : Project_Id) return Boolean is
1352 Variable : Variable_Value;
1353
1354 begin
1355 Variable :=
1356 Value_Of (Name_Source_Dirs, Project.Decl.Attributes, Shared);
1357
1358 if Variable = Nil_Variable_Value
1359 or else Variable.Default
1360 or else Variable.Values /= Nil_String
1361 then
1362 Variable :=
1363 Value_Of (Name_Source_Files, Project.Decl.Attributes, Shared);
1364 return Variable = Nil_Variable_Value
1365 or else Variable.Default
1366 or else Variable.Values /= Nil_String;
1367
1368 else
1369 return False;
1370 end if;
1371 end Might_Have_Sources;
1372
1373 -- Local Variables
1374
1375 Success : Boolean;
1376 Config_Project_Node : Project_Node_Id := Empty_Node;
1377
1378 -- Start of processing for Get_Or_Create_Configuration_File
1379
1380 begin
1381 pragma Assert (Prj.Env.Is_Initialized (Env.Project_Path));
1382
1383 Free (Config_File_Path);
1384 Config := No_Project;
1385
1386 Get_Project_Target;
1387 Check_Builder_Switches;
1388
1389 -- Do not attempt to find a configuration project file when
1390 -- Config_File_Name is No_Configuration_File.
1391
1392 if Config_File_Name = No_Configuration_File then
1393 Config_File_Path := null;
1394
1395 else
1396 if Conf_File_Name'Length > 0 then
1397 Config_File_Path := Locate_Config_File (Conf_File_Name.all);
1398 else
1399 Config_File_Path := Locate_Config_File (Default_File_Name);
1400 end if;
1401
1402 if Config_File_Path = null then
1403 if not Allow_Automatic_Generation
1404 and then Conf_File_Name'Length > 0
1405 then
1406 Raise_Invalid_Config
1407 ("could not locate main configuration project "
1408 & Conf_File_Name.all);
1409 end if;
1410 end if;
1411 end if;
1412
1413 Automatically_Generated :=
1414 Allow_Automatic_Generation and then Config_File_Path = null;
1415
1416 <<Process_Config_File>>
1417
1418 if Automatically_Generated then
1419
1420 -- This might raise an Invalid_Config exception
1421
1422 Do_Autoconf;
1423
1424 -- If the config file is not auto-generated, warn if there is any --RTS
1425 -- switch, but not when the config file is generated in memory.
1426
1427 elsif RTS_Languages.Get_First /= No_Name
1428 and then Opt.Warning_Mode /= Opt.Suppress
1429 and then On_Load_Config = null
1430 then
1431 Write_Line
1432 ("warning: " &
1433 "--RTS is taken into account only in auto-configuration");
1434 end if;
1435
1436 -- Parse the configuration file
1437
1438 if Verbose_Mode and then Config_File_Path /= null then
1439 Write_Str ("Checking configuration ");
1440 Write_Line (Config_File_Path.all);
1441 end if;
1442
1443 if Config_File_Path /= null then
1444 Prj.Part.Parse
1445 (In_Tree => Project_Node_Tree,
1446 Project => Config_Project_Node,
1447 Project_File_Name => Config_File_Path.all,
1448 Errout_Handling => Prj.Part.Finalize_If_Error,
1449 Packages_To_Check => Packages_To_Check,
1450 Current_Directory => Current_Directory,
1451 Is_Config_File => True,
1452 Env => Env);
1453 else
1454 Config_Project_Node := Empty_Node;
1455 end if;
1456
1457 if On_Load_Config /= null then
1458 On_Load_Config
1459 (Config_File => Config_Project_Node,
1460 Project_Node_Tree => Project_Node_Tree);
1461 end if;
1462
1463 if Config_Project_Node /= Empty_Node then
1464 Prj.Proc.Process_Project_Tree_Phase_1
1465 (In_Tree => Project_Tree,
1466 Project => Config,
1467 Packages_To_Check => Packages_To_Check,
1468 Success => Success,
1469 From_Project_Node => Config_Project_Node,
1470 From_Project_Node_Tree => Project_Node_Tree,
1471 Env => Env,
1472 Reset_Tree => False,
1473 On_New_Tree_Loaded => null);
1474 end if;
1475
1476 if Config_Project_Node = Empty_Node or else Config = No_Project then
1477 Raise_Invalid_Config
1478 ("processing of configuration project """
1479 & Config_File_Path.all & """ failed");
1480 end if;
1481
1482 -- Check that the target of the configuration file is the one the user
1483 -- specified on the command line. We do not need to check that when in
1484 -- auto-conf mode, since the appropriate target was passed to gprconfig.
1485
1486 if not Automatically_Generated
1487 and then not
1488 Check_Target
1489 (Config, Autoconf_Specified, Project_Tree, Selected_Target.all)
1490 then
1491 Automatically_Generated := True;
1492 goto Process_Config_File;
1493 end if;
1494 end Get_Or_Create_Configuration_File;
1495
1496 ------------------------
1497 -- Locate_Config_File --
1498 ------------------------
1499
1500 function Locate_Config_File (Name : String) return String_Access is
1501 Prefix_Path : constant String := Executable_Prefix_Path;
1502 begin
1503 if Prefix_Path'Length /= 0 then
1504 return Locate_Regular_File
1505 (Name,
1506 "." & Path_Separator &
1507 Prefix_Path & "share" & Directory_Separator & "gpr");
1508 else
1509 return Locate_Regular_File (Name, ".");
1510 end if;
1511 end Locate_Config_File;
1512
1513 --------------------
1514 -- Locate_Runtime --
1515 --------------------
1516
1517 procedure Locate_Runtime
1518 (Language : Name_Id;
1519 Env : Prj.Tree.Environment)
1520 is
1521 function Is_Base_Name (Path : String) return Boolean;
1522 -- Returns True if Path has no directory separator
1523
1524 ------------------
1525 -- Is_Base_Name --
1526 ------------------
1527
1528 function Is_Base_Name (Path : String) return Boolean is
1529 begin
1530 for J in Path'Range loop
1531 if Is_Directory_Separator (Path (J)) then
1532 return False;
1533 end if;
1534 end loop;
1535
1536 return True;
1537 end Is_Base_Name;
1538
1539 -- Local declarations
1540
1541 function Find_Rts_In_Path is new Prj.Env.Find_Name_In_Path
1542 (Check_Filename => Is_Directory);
1543
1544 RTS_Name : constant String := Runtime_Name_For (Language);
1545
1546 Full_Path : String_Access;
1547
1548 -- Start of processing for Locate_Runtime
1549
1550 begin
1551 if not Is_Base_Name (RTS_Name) then
1552 Full_Path :=
1553 Find_Rts_In_Path (Env.Project_Path, RTS_Name);
1554
1555 if Full_Path = null then
1556 Raise_Invalid_Config ("cannot find RTS " & RTS_Name);
1557 end if;
1558
1559 Set_Runtime_For (Language, Normalize_Pathname (Full_Path.all));
1560 Free (Full_Path);
1561 end if;
1562 end Locate_Runtime;
1563
1564 ------------------------------------
1565 -- Parse_Project_And_Apply_Config --
1566 ------------------------------------
1567
1568 procedure Parse_Project_And_Apply_Config
1569 (Main_Project : out Prj.Project_Id;
1570 User_Project_Node : out Prj.Tree.Project_Node_Id;
1571 Config_File_Name : String := "";
1572 Autoconf_Specified : Boolean;
1573 Project_File_Name : String;
1574 Project_Tree : Prj.Project_Tree_Ref;
1575 Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
1576 Env : in out Prj.Tree.Environment;
1577 Packages_To_Check : String_List_Access;
1578 Allow_Automatic_Generation : Boolean := True;
1579 Automatically_Generated : out Boolean;
1580 Config_File_Path : out String_Access;
1581 Target_Name : String := "";
1582 Normalized_Hostname : String;
1583 On_Load_Config : Config_File_Hook := null;
1584 Implicit_Project : Boolean := False;
1585 On_New_Tree_Loaded : Prj.Proc.Tree_Loaded_Callback := null)
1586 is
1587 begin
1588 pragma Assert (Prj.Env.Is_Initialized (Env.Project_Path));
1589
1590 -- Parse the user project tree
1591
1592 Prj.Initialize (Project_Tree);
1593
1594 Main_Project := No_Project;
1595 Automatically_Generated := False;
1596
1597 Prj.Part.Parse
1598 (In_Tree => Project_Node_Tree,
1599 Project => User_Project_Node,
1600 Project_File_Name => Project_File_Name,
1601 Errout_Handling => Prj.Part.Finalize_If_Error,
1602 Packages_To_Check => Packages_To_Check,
1603 Current_Directory => Current_Directory,
1604 Is_Config_File => False,
1605 Env => Env,
1606 Implicit_Project => Implicit_Project);
1607
1608 if User_Project_Node = Empty_Node then
1609 return;
1610 end if;
1611
1612 Process_Project_And_Apply_Config
1613 (Main_Project => Main_Project,
1614 User_Project_Node => User_Project_Node,
1615 Config_File_Name => Config_File_Name,
1616 Autoconf_Specified => Autoconf_Specified,
1617 Project_Tree => Project_Tree,
1618 Project_Node_Tree => Project_Node_Tree,
1619 Env => Env,
1620 Packages_To_Check => Packages_To_Check,
1621 Allow_Automatic_Generation => Allow_Automatic_Generation,
1622 Automatically_Generated => Automatically_Generated,
1623 Config_File_Path => Config_File_Path,
1624 Target_Name => Target_Name,
1625 Normalized_Hostname => Normalized_Hostname,
1626 On_Load_Config => On_Load_Config,
1627 On_New_Tree_Loaded => On_New_Tree_Loaded);
1628 end Parse_Project_And_Apply_Config;
1629
1630 --------------------------------------
1631 -- Process_Project_And_Apply_Config --
1632 --------------------------------------
1633
1634 procedure Process_Project_And_Apply_Config
1635 (Main_Project : out Prj.Project_Id;
1636 User_Project_Node : Prj.Tree.Project_Node_Id;
1637 Config_File_Name : String := "";
1638 Autoconf_Specified : Boolean;
1639 Project_Tree : Prj.Project_Tree_Ref;
1640 Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
1641 Env : in out Prj.Tree.Environment;
1642 Packages_To_Check : String_List_Access;
1643 Allow_Automatic_Generation : Boolean := True;
1644 Automatically_Generated : out Boolean;
1645 Config_File_Path : out String_Access;
1646 Target_Name : String := "";
1647 Normalized_Hostname : String;
1648 On_Load_Config : Config_File_Hook := null;
1649 Reset_Tree : Boolean := True;
1650 On_New_Tree_Loaded : Prj.Proc.Tree_Loaded_Callback := null)
1651 is
1652 Shared : constant Shared_Project_Tree_Data_Access :=
1653 Project_Tree.Shared;
1654 Main_Config_Project : Project_Id;
1655 Success : Boolean;
1656
1657 Conf_Project : Project_Id := No_Project;
1658 -- The object directory of this project is used to store the config
1659 -- project file in auto-configuration. Set by Check_Project below.
1660
1661 procedure Check_Project (Project : Project_Id);
1662 -- Look for a non aggregate project. If one is found, put its project Id
1663 -- in Conf_Project.
1664
1665 -------------------
1666 -- Check_Project --
1667 -------------------
1668
1669 procedure Check_Project (Project : Project_Id) is
1670 begin
1671 if Project.Qualifier = Aggregate
1672 or else
1673 Project.Qualifier = Aggregate_Library
1674 then
1675 declare
1676 List : Aggregated_Project_List := Project.Aggregated_Projects;
1677
1678 begin
1679 -- Look for a non aggregate project until one is found
1680
1681 while Conf_Project = No_Project and then List /= null loop
1682 Check_Project (List.Project);
1683 List := List.Next;
1684 end loop;
1685 end;
1686
1687 else
1688 Conf_Project := Project;
1689 end if;
1690 end Check_Project;
1691
1692 -- Start of processing for Process_Project_And_Apply_Config
1693
1694 begin
1695 Main_Project := No_Project;
1696 Automatically_Generated := False;
1697
1698 Process_Project_Tree_Phase_1
1699 (In_Tree => Project_Tree,
1700 Project => Main_Project,
1701 Packages_To_Check => Packages_To_Check,
1702 Success => Success,
1703 From_Project_Node => User_Project_Node,
1704 From_Project_Node_Tree => Project_Node_Tree,
1705 Env => Env,
1706 Reset_Tree => Reset_Tree,
1707 On_New_Tree_Loaded => On_New_Tree_Loaded);
1708
1709 if not Success then
1710 Main_Project := No_Project;
1711 return;
1712 end if;
1713
1714 if Project_Tree.Source_Info_File_Name /= null then
1715 if not Is_Absolute_Path (Project_Tree.Source_Info_File_Name.all) then
1716 declare
1717 Obj_Dir : constant Variable_Value :=
1718 Value_Of
1719 (Name_Object_Dir,
1720 Main_Project.Decl.Attributes,
1721 Shared);
1722
1723 begin
1724 if Obj_Dir = Nil_Variable_Value or else Obj_Dir.Default then
1725 Get_Name_String (Main_Project.Directory.Display_Name);
1726
1727 else
1728 if Is_Absolute_Path (Get_Name_String (Obj_Dir.Value)) then
1729 Get_Name_String (Obj_Dir.Value);
1730
1731 else
1732 Name_Len := 0;
1733 Add_Str_To_Name_Buffer
1734 (Get_Name_String (Main_Project.Directory.Display_Name));
1735 Add_Str_To_Name_Buffer (Get_Name_String (Obj_Dir.Value));
1736 end if;
1737 end if;
1738
1739 Add_Char_To_Name_Buffer (Directory_Separator);
1740 Add_Str_To_Name_Buffer (Project_Tree.Source_Info_File_Name.all);
1741 Free (Project_Tree.Source_Info_File_Name);
1742 Project_Tree.Source_Info_File_Name :=
1743 new String'(Name_Buffer (1 .. Name_Len));
1744 end;
1745 end if;
1746
1747 Read_Source_Info_File (Project_Tree);
1748 end if;
1749
1750 -- Get the first project that is not an aggregate project or an
1751 -- aggregate library project. The object directory of this project will
1752 -- be used to store the config project file in auto-configuration.
1753
1754 Check_Project (Main_Project);
1755
1756 -- Fail if there is only aggregate projects and aggregate library
1757 -- projects in the project tree.
1758
1759 if Conf_Project = No_Project then
1760 Raise_Invalid_Config ("there are no non-aggregate projects");
1761 end if;
1762
1763 -- Find configuration file
1764
1765 Get_Or_Create_Configuration_File
1766 (Config => Main_Config_Project,
1767 Project => Main_Project,
1768 Conf_Project => Conf_Project,
1769 Project_Tree => Project_Tree,
1770 Project_Node_Tree => Project_Node_Tree,
1771 Env => Env,
1772 Allow_Automatic_Generation => Allow_Automatic_Generation,
1773 Config_File_Name => Config_File_Name,
1774 Autoconf_Specified => Autoconf_Specified,
1775 Target_Name => Target_Name,
1776 Normalized_Hostname => Normalized_Hostname,
1777 Packages_To_Check => Packages_To_Check,
1778 Config_File_Path => Config_File_Path,
1779 Automatically_Generated => Automatically_Generated,
1780 On_Load_Config => On_Load_Config);
1781
1782 Apply_Config_File (Main_Config_Project, Project_Tree);
1783
1784 -- Finish processing the user's project
1785
1786 Prj.Proc.Process_Project_Tree_Phase_2
1787 (In_Tree => Project_Tree,
1788 Project => Main_Project,
1789 Success => Success,
1790 From_Project_Node => User_Project_Node,
1791 From_Project_Node_Tree => Project_Node_Tree,
1792 Env => Env);
1793
1794 if Success then
1795 if Project_Tree.Source_Info_File_Name /= null
1796 and then not Project_Tree.Source_Info_File_Exists
1797 then
1798 Write_Source_Info_File (Project_Tree);
1799 end if;
1800
1801 else
1802 Main_Project := No_Project;
1803 end if;
1804 end Process_Project_And_Apply_Config;
1805
1806 --------------------------
1807 -- Raise_Invalid_Config --
1808 --------------------------
1809
1810 procedure Raise_Invalid_Config (Msg : String) is
1811 begin
1812 Raise_Exception (Invalid_Config'Identity, Msg);
1813 end Raise_Invalid_Config;
1814
1815 ----------------------
1816 -- Runtime_Name_For --
1817 ----------------------
1818
1819 function Runtime_Name_For (Language : Name_Id) return String is
1820 begin
1821 if RTS_Languages.Get (Language) /= No_Name then
1822 return Get_Name_String (RTS_Languages.Get (Language));
1823 else
1824 return "";
1825 end if;
1826 end Runtime_Name_For;
1827
1828 --------------------------
1829 -- Runtime_Name_Set_For --
1830 --------------------------
1831
1832 function Runtime_Name_Set_For (Language : Name_Id) return Boolean is
1833 begin
1834 return RTS_Languages.Get (Language) /= No_Name;
1835 end Runtime_Name_Set_For;
1836
1837 ---------------------
1838 -- Set_Runtime_For --
1839 ---------------------
1840
1841 procedure Set_Runtime_For (Language : Name_Id; RTS_Name : String) is
1842 begin
1843 Name_Len := RTS_Name'Length;
1844 Name_Buffer (1 .. Name_Len) := RTS_Name;
1845 RTS_Languages.Set (Language, Name_Find);
1846 end Set_Runtime_For;
1847
1848 end Prj.Conf;
Mirror of the offical gcc git repository hosted at gcc.gnu.org