1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2006-2014, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Makeutl
; use Makeutl
;
29 with Output
; use Output
;
34 with Prj
.Proc
; use Prj
.Proc
;
35 with Prj
.Tree
; use Prj
.Tree
;
36 with Prj
.Util
; use Prj
.Util
;
38 with Snames
; use Snames
;
40 with Ada
.Directories
; use Ada
.Directories
;
41 with Ada
.Exceptions
; use Ada
.Exceptions
;
43 with GNAT
.Case_Util
; use GNAT
.Case_Util
;
44 with GNAT
.HTable
; use GNAT
.HTable
;
46 package body Prj
.Conf
is
48 Auto_Cgpr
: constant String := "auto.cgpr";
50 Config_Project_Env_Var
: constant String := "GPR_CONFIG";
51 -- Name of the environment variable that provides the name of the
52 -- configuration file to use.
54 Gprconfig_Name
: constant String := "gprconfig";
56 Warn_For_RTS
: Boolean := True;
57 -- Set to False when gprbuild parse again the project files, to avoid
58 -- an incorrect warning.
60 type Runtime_Root_Data
;
61 type Runtime_Root_Ptr
is access Runtime_Root_Data
;
62 type Runtime_Root_Data
is record
64 Next
: Runtime_Root_Ptr
;
66 -- Data for a runtime root to be used when adding directories to the
69 type Compiler_Root_Data
;
70 type Compiler_Root_Ptr
is access Compiler_Root_Data
;
71 type Compiler_Root_Data
is record
73 Runtimes
: Runtime_Root_Ptr
;
74 Next
: Compiler_Root_Ptr
;
76 -- Data for a compiler root to be used when adding directories to the
79 First_Compiler_Root
: Compiler_Root_Ptr
:= null;
80 -- Head of the list of compiler roots
82 package RTS_Languages
is new GNAT
.HTable
.Simple_HTable
83 (Header_Num
=> Prj
.Header_Num
,
85 No_Element
=> No_Name
,
89 -- Stores the runtime names for the various languages. This is in general
90 -- set from a --RTS command line option.
92 -----------------------
93 -- Local_Subprograms --
94 -----------------------
97 (Config_File
: Prj
.Project_Id
;
98 Autoconf_Specified
: Boolean;
99 Project_Tree
: Prj
.Project_Tree_Ref
;
100 Target
: String := "") return Boolean;
101 -- Check that the config file's target matches Target.
102 -- Target should be set to the empty string when the user did not specify
103 -- a target. If the target in the configuration file is invalid, this
104 -- function will raise Invalid_Config with an appropriate message.
105 -- Autoconf_Specified should be set to True if the user has used
108 function Locate_Config_File
(Name
: String) return String_Access
;
109 -- Search for Name in the config files directory. Return full path if
110 -- found, or null otherwise.
112 procedure Raise_Invalid_Config
(Msg
: String);
113 pragma No_Return
(Raise_Invalid_Config
);
114 -- Raises exception Invalid_Config with given message
116 procedure Apply_Config_File
117 (Config_File
: Prj
.Project_Id
;
118 Project_Tree
: Prj
.Project_Tree_Ref
);
119 -- Apply the configuration file settings to all the projects in the
120 -- project tree. The Project_Tree must have been parsed first, and
121 -- processed through the first phase so that all its projects are known.
123 -- Currently, this will add new attributes and packages in the various
124 -- projects, so that when the second phase of the processing is performed
125 -- these attributes are automatically taken into account.
127 type State
is (No_State
);
129 procedure Look_For_Project_Paths
130 (Project
: Project_Id
;
131 Tree
: Project_Tree_Ref
;
132 With_State
: in out State
);
133 -- Check the compilers in the Project and add record them in the list
134 -- rooted at First_Compiler_Root, with their runtimes, if they are not
135 -- already in the list.
137 procedure Update_Project_Path
is new
138 For_Every_Project_Imported
140 Action
=> Look_For_Project_Paths
);
142 ------------------------------------
143 -- Add_Default_GNAT_Naming_Scheme --
144 ------------------------------------
146 procedure Add_Default_GNAT_Naming_Scheme
147 (Config_File
: in out Project_Node_Id
;
148 Project_Tree
: Project_Node_Tree_Ref
)
150 procedure Create_Attribute
153 Index
: String := "";
154 Pkg
: Project_Node_Id
:= Empty_Node
);
156 ----------------------
157 -- Create_Attribute --
158 ----------------------
160 procedure Create_Attribute
163 Index
: String := "";
164 Pkg
: Project_Node_Id
:= Empty_Node
)
166 Attr
: Project_Node_Id
;
167 pragma Unreferenced
(Attr
);
169 Expr
: Name_Id
:= No_Name
;
170 Val
: Name_Id
:= No_Name
;
171 Parent
: Project_Node_Id
:= Config_File
;
175 Name_Len
:= Index
'Length;
176 Name_Buffer
(1 .. Name_Len
) := Index
;
180 if Pkg
/= Empty_Node
then
184 Name_Len
:= Value
'Length;
185 Name_Buffer
(1 .. Name_Len
) := Value
;
188 Attr
:= Create_Attribute
189 (Tree
=> Project_Tree
,
190 Prj_Or_Pkg
=> Parent
,
194 Value
=> Create_Literal_String
(Expr
, Project_Tree
));
195 end Create_Attribute
;
200 Naming
: Project_Node_Id
;
201 Compiler
: Project_Node_Id
;
203 -- Start of processing for Add_Default_GNAT_Naming_Scheme
206 if Config_File
= Empty_Node
then
208 -- Create a dummy config file if none was found
210 Name_Len
:= Auto_Cgpr
'Length;
211 Name_Buffer
(1 .. Name_Len
) := Auto_Cgpr
;
214 -- An invalid project name to avoid conflicts with user-created ones
217 Name_Buffer
(1 .. Name_Len
) := "_auto";
221 (In_Tree
=> Project_Tree
,
223 Full_Path
=> Path_Name_Type
(Name
),
224 Is_Config_File
=> True);
226 -- Setup library support
228 case MLib
.Tgt
.Support_For_Libraries
is
233 Create_Attribute
(Name_Library_Support
, "static_only");
236 Create_Attribute
(Name_Library_Support
, "full");
239 if MLib
.Tgt
.Standalone_Library_Auto_Init_Is_Supported
then
240 Create_Attribute
(Name_Library_Auto_Init_Supported
, "true");
242 Create_Attribute
(Name_Library_Auto_Init_Supported
, "false");
245 -- Declare an empty target
247 Create_Attribute
(Name_Target
, "");
249 -- Setup Ada support (Ada is the default language here, since this
250 -- is only called when no config file existed initially, ie for
253 Create_Attribute
(Name_Default_Language
, "ada");
255 Compiler
:= Create_Package
(Project_Tree
, Config_File
, "compiler");
257 (Name_Driver
, "gcc", "ada", Pkg
=> Compiler
);
259 (Name_Language_Kind
, "unit_based", "ada", Pkg
=> Compiler
);
261 (Name_Dependency_Kind
, "ALI_File", "ada", Pkg
=> Compiler
);
263 Naming
:= Create_Package
(Project_Tree
, Config_File
, "naming");
264 Create_Attribute
(Name_Spec_Suffix
, ".ads", "ada", Pkg
=> Naming
);
265 Create_Attribute
(Name_Separate_Suffix
, ".adb", "ada", Pkg
=> Naming
);
266 Create_Attribute
(Name_Body_Suffix
, ".adb", "ada", Pkg
=> Naming
);
267 Create_Attribute
(Name_Dot_Replacement
, "-", Pkg
=> Naming
);
268 Create_Attribute
(Name_Casing
, "lowercase", Pkg
=> Naming
);
270 if Current_Verbosity
= High
then
271 Write_Line
("Automatically generated (in-memory) config file");
273 (Project
=> Config_File
,
274 In_Tree
=> Project_Tree
,
275 Backward_Compatibility
=> False);
278 end Add_Default_GNAT_Naming_Scheme
;
280 -----------------------
281 -- Apply_Config_File --
282 -----------------------
284 procedure Apply_Config_File
285 (Config_File
: Prj
.Project_Id
;
286 Project_Tree
: Prj
.Project_Tree_Ref
)
288 procedure Add_Attributes
289 (Project_Tree
: Project_Tree_Ref
;
290 Conf_Decl
: Declarations
;
291 User_Decl
: in out Declarations
);
292 -- Process the attributes in the config declarations. For
293 -- single string values, if the attribute is not declared in
294 -- the user declarations, declare it with the value in the
295 -- config declarations. For string list values, prepend the
296 -- value in the user declarations with the value in the config
303 procedure Add_Attributes
304 (Project_Tree
: Project_Tree_Ref
;
305 Conf_Decl
: Declarations
;
306 User_Decl
: in out Declarations
)
308 Shared
: constant Shared_Project_Tree_Data_Access
:=
310 Conf_Attr_Id
: Variable_Id
;
311 Conf_Attr
: Variable
;
312 Conf_Array_Id
: Array_Id
;
313 Conf_Array
: Array_Data
;
314 Conf_Array_Elem_Id
: Array_Element_Id
;
315 Conf_Array_Elem
: Array_Element
;
316 Conf_List
: String_List_Id
;
317 Conf_List_Elem
: String_Element
;
319 User_Attr_Id
: Variable_Id
;
320 User_Attr
: Variable
;
321 User_Array_Id
: Array_Id
;
322 User_Array
: Array_Data
;
323 User_Array_Elem_Id
: Array_Element_Id
;
324 User_Array_Elem
: Array_Element
;
327 Conf_Attr_Id
:= Conf_Decl
.Attributes
;
328 User_Attr_Id
:= User_Decl
.Attributes
;
330 while Conf_Attr_Id
/= No_Variable
loop
331 Conf_Attr
:= Shared
.Variable_Elements
.Table
(Conf_Attr_Id
);
332 User_Attr
:= Shared
.Variable_Elements
.Table
(User_Attr_Id
);
334 if not Conf_Attr
.Value
.Default
then
335 if User_Attr
.Value
.Default
then
337 -- No attribute declared in user project file: just copy
338 -- the value of the configuration attribute.
340 User_Attr
.Value
:= Conf_Attr
.Value
;
341 Shared
.Variable_Elements
.Table
(User_Attr_Id
) := User_Attr
;
343 elsif User_Attr
.Value
.Kind
= List
344 and then Conf_Attr
.Value
.Values
/= Nil_String
346 -- List attribute declared in both the user project and the
347 -- configuration project: prepend the user list with the
348 -- configuration list.
351 User_List
: constant String_List_Id
:=
352 User_Attr
.Value
.Values
;
353 Conf_List
: String_List_Id
:= Conf_Attr
.Value
.Values
;
354 Conf_Elem
: String_Element
;
355 New_List
: String_List_Id
;
356 New_Elem
: String_Element
;
361 String_Element_Table
.Increment_Last
362 (Shared
.String_Elements
);
364 String_Element_Table
.Last
(Shared
.String_Elements
);
366 -- Value of attribute is new list
368 User_Attr
.Value
.Values
:= New_List
;
369 Shared
.Variable_Elements
.Table
(User_Attr_Id
) :=
373 -- Get each element of configuration list
375 Conf_Elem
:= Shared
.String_Elements
.Table
(Conf_List
);
376 New_Elem
:= Conf_Elem
;
377 Conf_List
:= Conf_Elem
.Next
;
379 if Conf_List
= Nil_String
then
381 -- If it is the last element in the list, connect
382 -- to first element of user list, and we are done.
384 New_Elem
.Next
:= User_List
;
385 Shared
.String_Elements
.Table
(New_List
) := New_Elem
;
389 -- If it is not the last element in the list, add
392 String_Element_Table
.Increment_Last
393 (Shared
.String_Elements
);
394 New_Elem
.Next
:= String_Element_Table
.Last
395 (Shared
.String_Elements
);
396 Shared
.String_Elements
.Table
(New_List
) := New_Elem
;
397 New_List
:= New_Elem
.Next
;
404 Conf_Attr_Id
:= Conf_Attr
.Next
;
405 User_Attr_Id
:= User_Attr
.Next
;
408 Conf_Array_Id
:= Conf_Decl
.Arrays
;
409 while Conf_Array_Id
/= No_Array
loop
410 Conf_Array
:= Shared
.Arrays
.Table
(Conf_Array_Id
);
412 User_Array_Id
:= User_Decl
.Arrays
;
413 while User_Array_Id
/= No_Array
loop
414 User_Array
:= Shared
.Arrays
.Table
(User_Array_Id
);
415 exit when User_Array
.Name
= Conf_Array
.Name
;
416 User_Array_Id
:= User_Array
.Next
;
419 -- If this associative array does not exist in the user project
420 -- file, do a shallow copy of the full associative array.
422 if User_Array_Id
= No_Array
then
423 Array_Table
.Increment_Last
(Shared
.Arrays
);
424 User_Array
:= Conf_Array
;
425 User_Array
.Next
:= User_Decl
.Arrays
;
426 User_Decl
.Arrays
:= Array_Table
.Last
(Shared
.Arrays
);
427 Shared
.Arrays
.Table
(User_Decl
.Arrays
) := User_Array
;
429 -- Otherwise, check each array element
432 Conf_Array_Elem_Id
:= Conf_Array
.Value
;
433 while Conf_Array_Elem_Id
/= No_Array_Element
loop
435 Shared
.Array_Elements
.Table
(Conf_Array_Elem_Id
);
437 User_Array_Elem_Id
:= User_Array
.Value
;
438 while User_Array_Elem_Id
/= No_Array_Element
loop
440 Shared
.Array_Elements
.Table
(User_Array_Elem_Id
);
441 exit when User_Array_Elem
.Index
= Conf_Array_Elem
.Index
;
442 User_Array_Elem_Id
:= User_Array_Elem
.Next
;
445 -- If the array element doesn't exist in the user array,
446 -- insert a shallow copy of the conf array element in the
449 if User_Array_Elem_Id
= No_Array_Element
then
450 Array_Element_Table
.Increment_Last
451 (Shared
.Array_Elements
);
452 User_Array_Elem
:= Conf_Array_Elem
;
453 User_Array_Elem
.Next
:= User_Array
.Value
;
455 Array_Element_Table
.Last
(Shared
.Array_Elements
);
456 Shared
.Array_Elements
.Table
(User_Array
.Value
) :=
458 Shared
.Arrays
.Table
(User_Array_Id
) := User_Array
;
460 -- Otherwise, if the value is a string list, prepend the
461 -- conf array element value to the array element.
463 elsif Conf_Array_Elem
.Value
.Kind
= List
then
464 Conf_List
:= Conf_Array_Elem
.Value
.Values
;
466 if Conf_List
/= Nil_String
then
468 Link
: constant String_List_Id
:=
469 User_Array_Elem
.Value
.Values
;
470 Previous
: String_List_Id
:= Nil_String
;
471 Next
: String_List_Id
;
476 Shared
.String_Elements
.Table
(Conf_List
);
477 String_Element_Table
.Increment_Last
478 (Shared
.String_Elements
);
480 String_Element_Table
.Last
481 (Shared
.String_Elements
);
482 Shared
.String_Elements
.Table
(Next
) :=
485 if Previous
= Nil_String
then
486 User_Array_Elem
.Value
.Values
:= Next
;
487 Shared
.Array_Elements
.Table
488 (User_Array_Elem_Id
) := User_Array_Elem
;
491 Shared
.String_Elements
.Table
492 (Previous
).Next
:= Next
;
497 Conf_List
:= Conf_List_Elem
.Next
;
499 if Conf_List
= Nil_String
then
500 Shared
.String_Elements
.Table
501 (Previous
).Next
:= Link
;
509 Conf_Array_Elem_Id
:= Conf_Array_Elem
.Next
;
513 Conf_Array_Id
:= Conf_Array
.Next
;
517 Shared
: constant Shared_Project_Tree_Data_Access
:= Project_Tree
.Shared
;
519 Conf_Decl
: constant Declarations
:= Config_File
.Decl
;
520 Conf_Pack_Id
: Package_Id
;
521 Conf_Pack
: Package_Element
;
523 User_Decl
: Declarations
;
524 User_Pack_Id
: Package_Id
;
525 User_Pack
: Package_Element
;
529 Debug_Output
("Applying config file to a project tree");
531 Proj
:= Project_Tree
.Projects
;
532 while Proj
/= null loop
533 if Proj
.Project
/= Config_File
then
534 User_Decl
:= Proj
.Project
.Decl
;
536 (Project_Tree
=> Project_Tree
,
537 Conf_Decl
=> Conf_Decl
,
538 User_Decl
=> User_Decl
);
540 Conf_Pack_Id
:= Conf_Decl
.Packages
;
541 while Conf_Pack_Id
/= No_Package
loop
542 Conf_Pack
:= Shared
.Packages
.Table
(Conf_Pack_Id
);
544 User_Pack_Id
:= User_Decl
.Packages
;
545 while User_Pack_Id
/= No_Package
loop
546 User_Pack
:= Shared
.Packages
.Table
(User_Pack_Id
);
547 exit when User_Pack
.Name
= Conf_Pack
.Name
;
548 User_Pack_Id
:= User_Pack
.Next
;
551 if User_Pack_Id
= No_Package
then
552 Package_Table
.Increment_Last
(Shared
.Packages
);
553 User_Pack
:= Conf_Pack
;
554 User_Pack
.Next
:= User_Decl
.Packages
;
555 User_Decl
.Packages
:= Package_Table
.Last
(Shared
.Packages
);
556 Shared
.Packages
.Table
(User_Decl
.Packages
) := User_Pack
;
560 (Project_Tree
=> Project_Tree
,
561 Conf_Decl
=> Conf_Pack
.Decl
,
562 User_Decl
=> Shared
.Packages
.Table
563 (User_Pack_Id
).Decl
);
566 Conf_Pack_Id
:= Conf_Pack
.Next
;
569 Proj
.Project
.Decl
:= User_Decl
;
571 -- For aggregate projects, we need to apply the config to all
572 -- their aggregated trees as well.
574 if Proj
.Project
.Qualifier
in Aggregate_Project
then
576 List
: Aggregated_Project_List
;
578 List
:= Proj
.Project
.Aggregated_Projects
;
579 while List
/= null loop
581 ("Recursively apply config to aggregated tree",
584 (Config_File
, Project_Tree
=> List
.Tree
);
593 end Apply_Config_File
;
599 function Check_Target
600 (Config_File
: Project_Id
;
601 Autoconf_Specified
: Boolean;
602 Project_Tree
: Prj
.Project_Tree_Ref
;
603 Target
: String := "") return Boolean
605 Shared
: constant Shared_Project_Tree_Data_Access
:=
607 Variable
: constant Variable_Value
:=
609 (Name_Target
, Config_File
.Decl
.Attributes
, Shared
);
610 Tgt_Name
: Name_Id
:= No_Name
;
614 if Variable
/= Nil_Variable_Value
and then not Variable
.Default
then
615 Tgt_Name
:= Variable
.Value
;
622 and then (Length_Of_Name
(Tgt_Name
) = 0
623 or else Target
= Get_Name_String
(Tgt_Name
)));
626 if Autoconf_Specified
then
628 Write_Line
("inconsistent targets, performing autoconf");
634 if Tgt_Name
/= No_Name
then
636 ("invalid target name """
637 & Get_Name_String
(Tgt_Name
) & """ in configuration");
640 ("no target specified in configuration file");
648 --------------------------------------
649 -- Get_Or_Create_Configuration_File --
650 --------------------------------------
652 procedure Get_Or_Create_Configuration_File
653 (Project
: Project_Id
;
654 Conf_Project
: Project_Id
;
655 Project_Tree
: Project_Tree_Ref
;
656 Project_Node_Tree
: Prj
.Tree
.Project_Node_Tree_Ref
;
657 Env
: in out Prj
.Tree
.Environment
;
658 Allow_Automatic_Generation
: Boolean;
659 Config_File_Name
: String := "";
660 Autoconf_Specified
: Boolean;
661 Target_Name
: String := "";
662 Normalized_Hostname
: String;
663 Packages_To_Check
: String_List_Access
:= null;
664 Config
: out Prj
.Project_Id
;
665 Config_File_Path
: out String_Access
;
666 Automatically_Generated
: out Boolean;
667 On_Load_Config
: Config_File_Hook
:= null)
669 Shared
: constant Shared_Project_Tree_Data_Access
:= Project_Tree
.Shared
;
671 At_Least_One_Compiler_Command
: Boolean := False;
672 -- Set to True if at least one attribute Ide'Compiler_Command is
673 -- specified for one language of the system.
675 Conf_File_Name
: String_Access
:= new String'(Config_File_Name);
676 -- The configuration project file name. May be modified if there are
677 -- switches --config= in the Builder package of the main project.
679 Selected_Target : String_Access := new String'(Target_Name
);
681 function Default_File_Name
return String;
682 -- Return the name of the default config file that should be tested
684 procedure Do_Autoconf
;
685 -- Generate a new config file through gprconfig. In case of error, this
686 -- raises the Invalid_Config exception with an appropriate message
688 procedure Check_Builder_Switches
;
689 -- Check for switches --config and --RTS in package Builder
691 procedure Get_Project_Target
;
692 -- If Target_Name is empty, get the specified target in the project
695 procedure Get_Project_Runtimes
;
696 -- Get the various Runtime (<lang>) in the project file or any project
697 -- it extends, if any are specified.
699 function Get_Config_Switches
return Argument_List_Access
;
700 -- Return the --config switches to use for gprconfig
702 function Get_Db_Switches
return Argument_List_Access
;
703 -- Return the --db switches to use for gprconfig
705 function Might_Have_Sources
(Project
: Project_Id
) return Boolean;
706 -- True if the specified project might have sources (ie the user has not
707 -- explicitly specified it. We haven't checked the file system, nor do
708 -- we need to at this stage.
710 ----------------------------
711 -- Check_Builder_Switches --
712 ----------------------------
714 procedure Check_Builder_Switches
is
715 Get_RTS_Switches
: constant Boolean :=
716 RTS_Languages
.Get_First
= No_Name
;
717 -- If no switch --RTS have been specified on the command line, look
718 -- for --RTS switches in the Builder switches.
720 Builder
: constant Package_Id
:=
721 Value_Of
(Name_Builder
, Project
.Decl
.Packages
, Shared
);
723 Switch_Array_Id
: Array_Element_Id
;
724 -- The Switches to be checked
726 procedure Check_Switches
;
727 -- Check the switches in Switch_Array_Id
733 procedure Check_Switches
is
734 Switch_Array
: Array_Element
;
735 Switch_List
: String_List_Id
:= Nil_String
;
736 Switch
: String_Element
;
738 Lang_Last
: Positive;
741 while Switch_Array_Id
/= No_Array_Element
loop
743 Shared
.Array_Elements
.Table
(Switch_Array_Id
);
745 Switch_List
:= Switch_Array
.Value
.Values
;
746 List_Loop
: while Switch_List
/= Nil_String
loop
747 Switch
:= Shared
.String_Elements
.Table
(Switch_List
);
749 if Switch
.Value
/= No_Name
then
750 Get_Name_String
(Switch
.Value
);
752 if Conf_File_Name
'Length = 0
753 and then Name_Len
> 9
754 and then Name_Buffer
(1 .. 9) = "--config="
757 new String'(Name_Buffer (10 .. Name_Len));
759 elsif Get_RTS_Switches
760 and then Name_Len >= 7
761 and then Name_Buffer (1 .. 5) = "--RTS"
763 if Name_Buffer (6) = '=' then
764 if not Runtime_Name_Set_For (Name_Ada) then
767 Name_Buffer (7 .. Name_Len));
771 and then Name_Buffer (6) = ':'
772 and then Name_Buffer (7) /= '='
775 while Lang_Last < Name_Len
776 and then Name_Buffer (Lang_Last + 1) /= '='
778 Lang_Last := Lang_Last + 1;
781 if Name_Buffer (Lang_Last + 1) = '=' then
783 RTS : constant String :=
784 Name_Buffer (Lang_Last + 2 .. Name_Len);
786 Name_Buffer (1 .. Lang_Last - 6) :=
787 Name_Buffer (7 .. Lang_Last);
788 Name_Len := Lang_Last - 6;
789 To_Lower (Name_Buffer (1 .. Name_Len));
792 if not Runtime_Name_Set_For (Lang) then
793 Set_Runtime_For (Lang, RTS);
801 Switch_List := Switch.Next;
804 Switch_Array_Id := Switch_Array.Next;
808 -- Start of processing for Check_Builder_Switches
811 if Builder /= No_Package then
814 (Name => Name_Switches,
815 In_Arrays => Shared.Packages.Table (Builder).Decl.Arrays,
821 (Name => Name_Default_Switches,
822 In_Arrays => Shared.Packages.Table (Builder).Decl.Arrays,
826 end Check_Builder_Switches;
828 ------------------------
829 -- Get_Project_Target --
830 ------------------------
832 procedure Get_Project_Target is
834 if Selected_Target'Length = 0 then
836 -- Check if attribute Target is specified in the main
837 -- project, or in a project it extends. If it is, use this
838 -- target to invoke gprconfig.
841 Variable : Variable_Value;
843 Tgt_Name : Name_Id := No_Name;
848 while Proj /= No_Project loop
850 Value_Of (Name_Target, Proj.Decl.Attributes, Shared);
852 if Variable /= Nil_Variable_Value
853 and then not Variable.Default
854 and then Variable.Value /= No_Name
856 Tgt_Name := Variable.Value;
860 Proj := Proj.Extends;
861 end loop Project_Loop;
863 if Tgt_Name /= No_Name then
864 Selected_Target := new String'(Get_Name_String
(Tgt_Name
));
868 end Get_Project_Target
;
870 --------------------------
871 -- Get_Project_Runtimes --
872 --------------------------
874 procedure Get_Project_Runtimes
is
875 Element
: Array_Element
;
876 Id
: Array_Element_Id
;
882 while Proj
/= No_Project
loop
883 Id
:= Value_Of
(Name_Runtime
, Proj
.Decl
.Arrays
, Shared
);
884 while Id
/= No_Array_Element
loop
885 Element
:= Shared
.Array_Elements
.Table
(Id
);
886 Lang
:= Element
.Index
;
888 if not Runtime_Name_Set_For
(Lang
) then
890 (Lang
, RTS_Name
=> Get_Name_String
(Element
.Value
.Value
));
896 Proj
:= Proj
.Extends
;
898 end Get_Project_Runtimes
;
900 -----------------------
901 -- Default_File_Name --
902 -----------------------
904 function Default_File_Name
return String is
905 Ada_RTS
: constant String := Runtime_Name_For
(Name_Ada
);
909 if Selected_Target
'Length /= 0 then
910 if Ada_RTS
/= "" then
912 Selected_Target
.all & '-' &
913 Ada_RTS
& Config_Project_File_Extension
;
916 Selected_Target
.all & Config_Project_File_Extension
;
919 elsif Ada_RTS
/= "" then
920 return Ada_RTS
& Config_Project_File_Extension
;
923 Tmp
:= Getenv
(Config_Project_Env_Var
);
926 T
: constant String := Tmp
.all;
932 return Default_Config_Name
;
938 end Default_File_Name
;
944 procedure Do_Autoconf
is
945 Obj_Dir
: constant Variable_Value
:=
948 Conf_Project
.Decl
.Attributes
,
951 Gprconfig_Path
: String_Access
;
955 Gprconfig_Path
:= Locate_Exec_On_Path
(Gprconfig_Name
);
957 if Gprconfig_Path
= null then
959 ("could not locate gprconfig for auto-configuration");
962 -- First, find the object directory of the Conf_Project
964 if Obj_Dir
= Nil_Variable_Value
or else Obj_Dir
.Default
then
965 Get_Name_String
(Conf_Project
.Directory
.Display_Name
);
968 if Is_Absolute_Path
(Get_Name_String
(Obj_Dir
.Value
)) then
969 Get_Name_String
(Obj_Dir
.Value
);
973 Add_Str_To_Name_Buffer
974 (Get_Name_String
(Conf_Project
.Directory
.Display_Name
));
975 Add_Str_To_Name_Buffer
(Get_Name_String
(Obj_Dir
.Value
));
979 if Subdirs
/= null then
980 Add_Char_To_Name_Buffer
(Directory_Separator
);
981 Add_Str_To_Name_Buffer
(Subdirs
.all);
984 for J
in 1 .. Name_Len
loop
985 if Name_Buffer
(J
) = '/' then
986 Name_Buffer
(J
) := Directory_Separator
;
990 -- Make sure that Obj_Dir ends with a directory separator
992 if Name_Buffer
(Name_Len
) /= Directory_Separator
then
993 Name_Len
:= Name_Len
+ 1;
994 Name_Buffer
(Name_Len
) := Directory_Separator
;
998 Obj_Dir
: constant String := Name_Buffer
(1 .. Name_Len
);
999 Config_Switches
: Argument_List_Access
;
1000 Db_Switches
: Argument_List_Access
;
1001 Args
: Argument_List
(1 .. 5);
1002 Arg_Last
: Positive;
1003 Obj_Dir_Exists
: Boolean := True;
1006 -- Check if the object directory exists. If Setup_Projects is True
1007 -- (-p) and directory does not exist, attempt to create it.
1008 -- Otherwise, if directory does not exist, fail without calling
1011 if not Is_Directory
(Obj_Dir
)
1012 and then (Setup_Projects
or else Subdirs
/= null)
1015 Create_Path
(Obj_Dir
);
1017 if not Quiet_Output
then
1018 Write_Str
("object directory """);
1019 Write_Str
(Obj_Dir
);
1020 Write_Line
(""" created");
1025 Raise_Invalid_Config
1026 ("could not create object directory " & Obj_Dir
);
1030 if not Is_Directory
(Obj_Dir
) then
1031 case Env
.Flags
.Require_Obj_Dirs
is
1033 Raise_Invalid_Config
1034 ("object directory " & Obj_Dir
& " does not exist");
1039 "?object directory " & Obj_Dir
& " does not exist");
1040 Obj_Dir_Exists
:= False;
1047 -- Get the config switches. This should be done only now, as some
1048 -- runtimes may have been found in the Builder switches.
1050 Config_Switches
:= Get_Config_Switches
;
1052 -- Get eventual --db switches
1054 Db_Switches
:= Get_Db_Switches
;
1058 Args
(1) := new String'("--batch");
1059 Args (2) := new String'("-o");
1061 -- If no config file was specified, set the auto.cgpr one
1063 if Conf_File_Name
'Length = 0 then
1064 if Obj_Dir_Exists
then
1065 Args
(3) := new String'(Obj_Dir & Auto_Cgpr);
1069 Path_FD : File_Descriptor;
1070 Path_Name : Path_Name_Type;
1073 Prj.Env.Create_Temp_File
1074 (Shared => Project_Tree.Shared,
1076 Path_Name => Path_Name,
1077 File_Use => "configuration file");
1079 if Path_FD /= Invalid_FD then
1081 Temp_Dir : constant String :=
1082 Containing_Directory
1083 (Get_Name_String (Path_Name));
1085 GNAT.OS_Lib.Close (Path_FD);
1087 new String'(Temp_Dir
&
1088 Directory_Separator
&
1090 Delete_File
(Get_Name_String
(Path_Name
));
1094 -- We'll have an error message later on
1096 Args
(3) := new String'(Obj_Dir & Auto_Cgpr);
1101 Args (3) := Conf_File_Name;
1104 if Normalized_Hostname = "" then
1107 if Selected_Target'Length = 0 then
1108 if At_Least_One_Compiler_Command then
1110 new String'("--target=all");
1113 new String'("--target=" & Normalized_Hostname);
1118 new String'("--target=" & Selected_Target
.all);
1124 if not Verbose_Mode
then
1125 Arg_Last
:= Arg_Last
+ 1;
1126 Args
(Arg_Last
) := new String'("-q");
1129 if Verbose_Mode then
1130 Write_Str (Gprconfig_Name);
1132 for J in 1 .. Arg_Last loop
1134 Write_Str (Args (J).all);
1137 for J in Config_Switches'Range loop
1139 Write_Str (Config_Switches (J).all);
1142 for J in Db_Switches'Range loop
1144 Write_Str (Db_Switches (J).all);
1149 elsif not Quiet_Output then
1151 -- Display no message if we are creating auto.cgpr, unless in
1154 if Config_File_Name'Length > 0 or else Verbose_Mode then
1155 Write_Str ("creating ");
1156 Write_Str (Simple_Name (Args (3).all));
1161 Spawn (Gprconfig_Path.all, Args (1 .. Arg_Last) &
1162 Config_Switches.all & Db_Switches.all,
1165 Free (Config_Switches);
1167 Config_File_Path := Locate_Config_File (Args (3).all);
1169 if Config_File_Path = null then
1170 Raise_Invalid_Config
1171 ("could not create " & Args (3).all);
1174 for F in Args'Range loop
1180 ---------------------
1181 -- Get_Db_Switches --
1182 ---------------------
1184 function Get_Db_Switches return Argument_List_Access is
1185 Result : Argument_List_Access;
1189 (2 * Db_Switch_Args.Last) + Boolean'Pos (not Load_Standard_Base);
1190 Result := new Argument_List (1 .. Nmb_Arg);
1192 if Nmb_Arg /= 0 then
1193 for J in 1 .. Db_Switch_Args.Last loop
1194 Result (2 * J - 1) :=
1195 new String'("--db");
1197 new String'(Get_Name_String (Db_Switch_Args.Table (J)));
1200 if not Load_Standard_Base then
1201 Result (Result'Last) := new String'("--db-");
1206 end Get_Db_Switches
;
1208 -------------------------
1209 -- Get_Config_Switches --
1210 -------------------------
1212 function Get_Config_Switches
return Argument_List_Access
is
1214 package Language_Htable
is new GNAT
.HTable
.Simple_HTable
1215 (Header_Num
=> Prj
.Header_Num
,
1217 No_Element
=> No_Name
,
1221 -- Hash table to keep the languages used in the project tree
1223 IDE
: constant Package_Id
:=
1224 Value_Of
(Name_Ide
, Project
.Decl
.Packages
, Shared
);
1226 procedure Add_Config_Switches_For_Project
1227 (Project
: Project_Id
;
1228 Tree
: Project_Tree_Ref
;
1229 With_State
: in out Integer);
1230 -- Add all --config switches for this project. This is also called
1231 -- for aggregate projects.
1233 -------------------------------------
1234 -- Add_Config_Switches_For_Project --
1235 -------------------------------------
1237 procedure Add_Config_Switches_For_Project
1238 (Project
: Project_Id
;
1239 Tree
: Project_Tree_Ref
;
1240 With_State
: in out Integer)
1242 pragma Unreferenced
(With_State
);
1244 Shared
: constant Shared_Project_Tree_Data_Access
:= Tree
.Shared
;
1246 Variable
: Variable_Value
;
1247 Check_Default
: Boolean;
1249 List
: String_List_Id
;
1250 Elem
: String_Element
;
1253 if Might_Have_Sources
(Project
) then
1255 Value_Of
(Name_Languages
, Project
.Decl
.Attributes
, Shared
);
1257 if Variable
= Nil_Variable_Value
or else Variable
.Default
then
1259 -- Languages is not declared. If it is not an extending
1260 -- project, or if it extends a project with no Languages,
1261 -- check for Default_Language.
1263 Check_Default
:= Project
.Extends
= No_Project
;
1265 if not Check_Default
then
1269 Project
.Extends
.Decl
.Attributes
,
1272 Variable
/= Nil_Variable_Value
1273 and then Variable
.Values
= Nil_String
;
1276 if Check_Default
then
1279 (Name_Default_Language
,
1280 Project
.Decl
.Attributes
,
1283 if Variable
/= Nil_Variable_Value
1284 and then not Variable
.Default
1286 Get_Name_String
(Variable
.Value
);
1287 To_Lower
(Name_Buffer
(1 .. Name_Len
));
1289 Language_Htable
.Set
(Lang
, Lang
);
1291 -- If no default language is declared, default to Ada
1294 Language_Htable
.Set
(Name_Ada
, Name_Ada
);
1298 elsif Variable
.Values
/= Nil_String
then
1300 -- Attribute Languages is declared with a non empty list:
1301 -- put all the languages in Language_HTable.
1303 List
:= Variable
.Values
;
1304 while List
/= Nil_String
loop
1305 Elem
:= Shared
.String_Elements
.Table
(List
);
1307 Get_Name_String
(Elem
.Value
);
1308 To_Lower
(Name_Buffer
(1 .. Name_Len
));
1310 Language_Htable
.Set
(Lang
, Lang
);
1316 end Add_Config_Switches_For_Project
;
1318 procedure For_Every_Imported_Project
is new For_Every_Project_Imported
1319 (State
=> Integer, Action
=> Add_Config_Switches_For_Project
);
1320 -- Document this procedure ???
1326 Result
: Argument_List_Access
;
1327 Variable
: Variable_Value
;
1328 Dummy
: Integer := 0;
1330 -- Start of processing for Get_Config_Switches
1333 For_Every_Imported_Project
1335 Tree
=> Project_Tree
,
1336 With_State
=> Dummy
,
1337 Include_Aggregated
=> True);
1339 Name
:= Language_Htable
.Get_First
;
1341 while Name
/= No_Name
loop
1343 Name
:= Language_Htable
.Get_Next
;
1346 Result
:= new String_List
(1 .. Count
);
1349 Name
:= Language_Htable
.Get_First
;
1350 while Name
/= No_Name
loop
1352 -- Check if IDE'Compiler_Command is declared for the language.
1353 -- If it is, use its value to invoke gprconfig.
1358 Attribute_Or_Array_Name
=> Name_Compiler_Command
,
1361 Force_Lower_Case_Index
=> True);
1364 Config_Command
: constant String :=
1365 "--config=" & Get_Name_String
(Name
);
1367 Runtime_Name
: constant String := Runtime_Name_For
(Name
);
1370 -- In CodePeer mode, we do not take into account any compiler
1371 -- command from the package IDE.
1374 or else Variable
= Nil_Variable_Value
1375 or else Length_Of_Name
(Variable
.Value
) = 0
1378 new String'(Config_Command & ",," & Runtime_Name);
1381 At_Least_One_Compiler_Command := True;
1384 Compiler_Command : constant String :=
1385 Get_Name_String (Variable.Value);
1388 if Is_Absolute_Path (Compiler_Command) then
1391 (Config_Command
& ",," & Runtime_Name
& ","
1392 & Containing_Directory
(Compiler_Command
) & ","
1393 & Simple_Name
(Compiler_Command
));
1397 (Config_Command & ",," & Runtime_Name & ",,"
1398 & Compiler_Command);
1405 Name := Language_Htable.Get_Next;
1409 end Get_Config_Switches;
1411 ------------------------
1412 -- Might_Have_Sources --
1413 ------------------------
1415 function Might_Have_Sources (Project : Project_Id) return Boolean is
1416 Variable : Variable_Value;
1420 Value_Of (Name_Source_Dirs, Project.Decl.Attributes, Shared);
1422 if Variable = Nil_Variable_Value
1423 or else Variable.Default
1424 or else Variable.Values /= Nil_String
1427 Value_Of (Name_Source_Files, Project.Decl.Attributes, Shared);
1428 return Variable = Nil_Variable_Value
1429 or else Variable.Default
1430 or else Variable.Values /= Nil_String;
1435 end Might_Have_Sources;
1440 Config_Project_Node : Project_Node_Id := Empty_Node;
1442 -- Start of processing for Get_Or_Create_Configuration_File
1445 pragma Assert (Prj.Env.Is_Initialized (Env.Project_Path));
1447 Free (Config_File_Path);
1448 Config := No_Project;
1451 Get_Project_Runtimes;
1452 Check_Builder_Switches;
1454 -- Do not attempt to find a configuration project file when
1455 -- Config_File_Name is No_Configuration_File.
1457 if Config_File_Name = No_Configuration_File then
1458 Config_File_Path := null;
1461 if Conf_File_Name'Length > 0 then
1462 Config_File_Path := Locate_Config_File (Conf_File_Name.all);
1464 Config_File_Path := Locate_Config_File (Default_File_Name);
1467 if Config_File_Path = null then
1468 if not Allow_Automatic_Generation
1469 and then Conf_File_Name'Length > 0
1471 Raise_Invalid_Config
1472 ("could not locate main configuration project "
1473 & Conf_File_Name.all);
1478 Automatically_Generated :=
1479 Allow_Automatic_Generation and then Config_File_Path = null;
1481 <<Process_Config_File>>
1483 if Automatically_Generated then
1485 -- This might raise an Invalid_Config exception
1489 -- If the config file is not auto-generated, warn if there is any --RTS
1490 -- switch, but not when the config file is generated in memory.
1493 and then RTS_Languages.Get_First /= No_Name
1494 and then Opt.Warning_Mode /= Opt.Suppress
1495 and then On_Load_Config = null
1499 "--RTS is taken into account only in auto-configuration");
1502 -- Parse the configuration file
1504 if Verbose_Mode and then Config_File_Path /= null then
1505 Write_Str ("Checking configuration ");
1506 Write_Line (Config_File_Path.all);
1509 if Config_File_Path /= null then
1511 (In_Tree => Project_Node_Tree,
1512 Project => Config_Project_Node,
1513 Project_File_Name => Config_File_Path.all,
1514 Errout_Handling => Prj.Part.Finalize_If_Error,
1515 Packages_To_Check => Packages_To_Check,
1516 Current_Directory => Current_Directory,
1517 Is_Config_File => True,
1520 Config_Project_Node := Empty_Node;
1523 if On_Load_Config /= null then
1525 (Config_File => Config_Project_Node,
1526 Project_Node_Tree => Project_Node_Tree);
1529 if Config_Project_Node /= Empty_Node then
1530 Prj.Proc.Process_Project_Tree_Phase_1
1531 (In_Tree => Project_Tree,
1533 Packages_To_Check => Packages_To_Check,
1535 From_Project_Node => Config_Project_Node,
1536 From_Project_Node_Tree => Project_Node_Tree,
1538 Reset_Tree => False,
1539 On_New_Tree_Loaded => null);
1542 if Config_Project_Node = Empty_Node or else Config = No_Project then
1543 Raise_Invalid_Config
1544 ("processing of configuration project """
1545 & Config_File_Path.all & """ failed");
1548 -- Check that the target of the configuration file is the one the user
1549 -- specified on the command line. We do not need to check that when in
1550 -- auto-conf mode, since the appropriate target was passed to gprconfig.
1552 if not Automatically_Generated
1555 (Config, Autoconf_Specified, Project_Tree, Selected_Target.all)
1557 Automatically_Generated := True;
1558 goto Process_Config_File;
1560 end Get_Or_Create_Configuration_File;
1562 ------------------------
1563 -- Locate_Config_File --
1564 ------------------------
1566 function Locate_Config_File (Name : String) return String_Access is
1567 Prefix_Path : constant String := Executable_Prefix_Path;
1569 if Prefix_Path'Length /= 0 then
1570 return Locate_Regular_File
1572 "." & Path_Separator &
1573 Prefix_Path & "share" & Directory_Separator & "gpr");
1575 return Locate_Regular_File (Name, ".");
1577 end Locate_Config_File;
1579 ------------------------------------
1580 -- Parse_Project_And_Apply_Config --
1581 ------------------------------------
1583 procedure Parse_Project_And_Apply_Config
1584 (Main_Project : out Prj.Project_Id;
1585 User_Project_Node : out Prj.Tree.Project_Node_Id;
1586 Config_File_Name : String := "";
1587 Autoconf_Specified : Boolean;
1588 Project_File_Name : String;
1589 Project_Tree : Prj.Project_Tree_Ref;
1590 Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
1591 Env : in out Prj.Tree.Environment;
1592 Packages_To_Check : String_List_Access;
1593 Allow_Automatic_Generation : Boolean := True;
1594 Automatically_Generated : out Boolean;
1595 Config_File_Path : out String_Access;
1596 Target_Name : String := "";
1597 Normalized_Hostname : String;
1598 On_Load_Config : Config_File_Hook := null;
1599 Implicit_Project : Boolean := False;
1600 On_New_Tree_Loaded : Prj.Proc.Tree_Loaded_Callback := null)
1602 Success : Boolean := False;
1603 Target_Try_Again : Boolean := True;
1604 Config_Try_Again : Boolean;
1606 S : State := No_State;
1608 Conf_File_Name : String_Access := new String'(Config_File_Name
);
1610 procedure Add_Directory
(Dir
: String);
1611 -- Add a directory at the end of the Project Path
1617 procedure Add_Directory
(Dir
: String) is
1619 if Opt
.Verbose_Mode
then
1620 Write_Line
(" Adding directory """ & Dir
& """");
1623 Prj
.Env
.Add_Directories
(Env
.Project_Path
, Dir
);
1627 pragma Assert
(Prj
.Env
.Is_Initialized
(Env
.Project_Path
));
1629 -- Start with ignoring missing withed projects
1631 Update_Ignore_Missing_With
(Env
.Flags
, True);
1633 -- Record Target_Value and Target_Origin.
1635 if Target_Name
= "" then
1636 Opt
.Target_Value
:= new String'(Normalized_Hostname);
1637 Opt.Target_Origin := Default;
1639 Opt.Target_Value := new String'(Target_Name
);
1640 Opt
.Target_Origin
:= Specified
;
1645 -- Parse the user project tree
1647 Prj
.Initialize
(Project_Tree
);
1649 Main_Project
:= No_Project
;
1650 Automatically_Generated
:= False;
1653 (In_Tree
=> Project_Node_Tree
,
1654 Project
=> User_Project_Node
,
1655 Project_File_Name
=> Project_File_Name
,
1656 Errout_Handling
=> Prj
.Part
.Finalize_If_Error
,
1657 Packages_To_Check
=> Packages_To_Check
,
1658 Current_Directory
=> Current_Directory
,
1659 Is_Config_File
=> False,
1661 Implicit_Project
=> Implicit_Project
);
1663 if User_Project_Node
= Empty_Node
then
1667 -- If --target was not specified on the command line, then do Phase 1 to
1668 -- check if attribute Target is declared in the main project.
1670 if Opt
.Target_Origin
/= Specified
then
1671 Main_Project
:= No_Project
;
1672 Process_Project_Tree_Phase_1
1673 (In_Tree
=> Project_Tree
,
1674 Project
=> Main_Project
,
1675 Packages_To_Check
=> Packages_To_Check
,
1677 From_Project_Node
=> User_Project_Node
,
1678 From_Project_Node_Tree
=> Project_Node_Tree
,
1681 On_New_Tree_Loaded
=> On_New_Tree_Loaded
);
1684 Main_Project
:= No_Project
;
1689 Variable
: constant Variable_Value
:=
1692 Main_Project
.Decl
.Attributes
,
1693 Project_Tree
.Shared
);
1695 if Variable
/= Nil_Variable_Value
1696 and then not Variable
.Default
1698 Get_Name_String
(Variable
.Value
) /= Opt
.Target_Value
.all
1700 if Target_Try_Again
then
1702 new String'(Get_Name_String (Variable.Value));
1703 Target_Try_Again := False;
1709 "inconsistent value of attribute Target");
1715 -- If there are missing withed projects, the projects will be parsed
1716 -- again after the project path is extended with directories rooted
1717 -- at the compiler roots.
1719 Config_Try_Again := Project_Node_Tree.Incomplete_With;
1721 Process_Project_And_Apply_Config
1722 (Main_Project => Main_Project,
1723 User_Project_Node => User_Project_Node,
1724 Config_File_Name => Conf_File_Name.all,
1725 Autoconf_Specified => Autoconf_Specified,
1726 Project_Tree => Project_Tree,
1727 Project_Node_Tree => Project_Node_Tree,
1729 Packages_To_Check => Packages_To_Check,
1730 Allow_Automatic_Generation => Allow_Automatic_Generation,
1731 Automatically_Generated => Automatically_Generated,
1732 Config_File_Path => Config_File_Path,
1733 Target_Name => Target_Name,
1734 Normalized_Hostname => Normalized_Hostname,
1735 On_Load_Config => On_Load_Config,
1736 On_New_Tree_Loaded => On_New_Tree_Loaded,
1737 Do_Phase_1 => Opt.Target_Origin = Specified);
1739 -- Exit if there was an error. Otherwise, if Config_Try_Again is True,
1740 -- update the project path and try again.
1742 if Main_Project /= No_Project and then Config_Try_Again then
1743 Update_Ignore_Missing_With (Env.Flags, False);
1745 if Config_File_Path /= null then
1746 Conf_File_Name := new String'(Simple_Name
(Config_File_Path
.all));
1749 -- For the second time the project files are parsed, the warning for
1750 -- --RTS= being only taken into account in auto-configuration are
1751 -- suppressed, as we are no longer in auto-configuration.
1753 Warn_For_RTS
:= False;
1755 -- Add the default directories corresponding to the compilers
1758 (By
=> Main_Project
,
1759 Tree
=> Project_Tree
,
1761 Include_Aggregated
=> True,
1762 Imported_First
=> False);
1765 Compiler_Root
: Compiler_Root_Ptr
;
1766 Prefix
: String_Access
;
1767 Runtime_Root
: Runtime_Root_Ptr
;
1768 Path_Value
: constant String_Access
:= Getenv
("PATH");
1771 if Opt
.Verbose_Mode
then
1772 Write_Line
("Setting the default project search directories");
1774 if Prj
.Current_Verbosity
= High
then
1775 if Path_Value
= null or else Path_Value
'Length = 0 then
1776 Write_Line
("No environment variable PATH");
1779 Write_Line
("PATH =");
1780 Write_Line
(" " & Path_Value
.all);
1785 -- Reorder the compiler roots in the PATH order
1787 if First_Compiler_Root
/= null
1788 and then First_Compiler_Root
.Next
/= null
1791 Pred
: Compiler_Root_Ptr
;
1792 First_New_Comp
: Compiler_Root_Ptr
:= null;
1793 New_Comp
: Compiler_Root_Ptr
:= null;
1794 First
: Positive := Path_Value
'First;
1796 Path_Last
: Positive;
1798 while First
<= Path_Value
'Last loop
1801 if Path_Value
(First
) /= Path_Separator
then
1802 while Last
< Path_Value
'Last
1803 and then Path_Value
(Last
+ 1) /= Path_Separator
1809 while Path_Last
> First
1811 Path_Value
(Path_Last
) = Directory_Separator
1813 Path_Last
:= Path_Last
- 1;
1816 if Path_Last
> First
+ 4
1818 Path_Value
(Path_Last
- 2 .. Path_Last
) = "bin"
1820 Path_Value
(Path_Last
- 3) = Directory_Separator
1822 Path_Last
:= Path_Last
- 4;
1824 Compiler_Root
:= First_Compiler_Root
;
1825 while Compiler_Root
/= null
1826 and then Compiler_Root
.Root
.all /=
1827 Path_Value
(First
.. Path_Last
)
1829 Pred
:= Compiler_Root
;
1830 Compiler_Root
:= Compiler_Root
.Next
;
1833 if Compiler_Root
/= null then
1835 First_Compiler_Root
:=
1836 First_Compiler_Root
.Next
;
1838 Pred
.Next
:= Compiler_Root
.Next
;
1841 if First_New_Comp
= null then
1842 First_New_Comp
:= Compiler_Root
;
1844 New_Comp
.Next
:= Compiler_Root
;
1847 New_Comp
:= Compiler_Root
;
1848 New_Comp
.Next
:= null;
1856 if First_New_Comp
/= null then
1857 New_Comp
.Next
:= First_Compiler_Root
;
1858 First_Compiler_Root
:= First_New_Comp
;
1863 -- Now that the compiler roots are in a correct order, add the
1864 -- directories corresponding to these compiler roots in the
1867 Compiler_Root
:= First_Compiler_Root
;
1868 while Compiler_Root
/= null loop
1869 Prefix
:= Compiler_Root
.Root
;
1871 Runtime_Root
:= Compiler_Root
.Runtimes
;
1872 while Runtime_Root
/= null loop
1874 (Runtime_Root
.Root
.all &
1875 Directory_Separator
&
1877 Directory_Separator
&
1880 (Runtime_Root
.Root
.all &
1881 Directory_Separator
&
1883 Directory_Separator
&
1885 Runtime_Root
:= Runtime_Root
.Next
;
1890 Directory_Separator
&
1891 Opt
.Target_Value
.all &
1892 Directory_Separator
&
1894 Directory_Separator
&
1898 Directory_Separator
&
1899 Opt
.Target_Value
.all &
1900 Directory_Separator
&
1902 Directory_Separator
&
1906 Directory_Separator
&
1908 Directory_Separator
&
1912 Directory_Separator
&
1914 Directory_Separator
&
1916 Compiler_Root
:= Compiler_Root
.Next
;
1920 -- And parse again the project files. There will be no missing
1921 -- withed projects, as Ignore_Missing_With is set to False in
1922 -- the environment flags, so there is no risk of endless loop here.
1926 end Parse_Project_And_Apply_Config
;
1928 --------------------------------------
1929 -- Process_Project_And_Apply_Config --
1930 --------------------------------------
1932 procedure Process_Project_And_Apply_Config
1933 (Main_Project
: out Prj
.Project_Id
;
1934 User_Project_Node
: Prj
.Tree
.Project_Node_Id
;
1935 Config_File_Name
: String := "";
1936 Autoconf_Specified
: Boolean;
1937 Project_Tree
: Prj
.Project_Tree_Ref
;
1938 Project_Node_Tree
: Prj
.Tree
.Project_Node_Tree_Ref
;
1939 Env
: in out Prj
.Tree
.Environment
;
1940 Packages_To_Check
: String_List_Access
;
1941 Allow_Automatic_Generation
: Boolean := True;
1942 Automatically_Generated
: out Boolean;
1943 Config_File_Path
: out String_Access
;
1944 Target_Name
: String := "";
1945 Normalized_Hostname
: String;
1946 On_Load_Config
: Config_File_Hook
:= null;
1947 Reset_Tree
: Boolean := True;
1948 On_New_Tree_Loaded
: Prj
.Proc
.Tree_Loaded_Callback
:= null;
1949 Do_Phase_1
: Boolean := True)
1951 Shared
: constant Shared_Project_Tree_Data_Access
:=
1952 Project_Tree
.Shared
;
1953 Main_Config_Project
: Project_Id
;
1956 Conf_Project
: Project_Id
:= No_Project
;
1957 -- The object directory of this project is used to store the config
1958 -- project file in auto-configuration. Set by Check_Project below.
1960 procedure Check_Project
(Project
: Project_Id
);
1961 -- Look for a non aggregate project. If one is found, put its project Id
1968 procedure Check_Project
(Project
: Project_Id
) is
1970 if Project
.Qualifier
= Aggregate
1972 Project
.Qualifier
= Aggregate_Library
1975 List
: Aggregated_Project_List
:= Project
.Aggregated_Projects
;
1978 -- Look for a non aggregate project until one is found
1980 while Conf_Project
= No_Project
and then List
/= null loop
1981 Check_Project
(List
.Project
);
1987 Conf_Project
:= Project
;
1991 -- Start of processing for Process_Project_And_Apply_Config
1994 Automatically_Generated
:= False;
1997 Main_Project
:= No_Project
;
1998 Process_Project_Tree_Phase_1
1999 (In_Tree
=> Project_Tree
,
2000 Project
=> Main_Project
,
2001 Packages_To_Check
=> Packages_To_Check
,
2003 From_Project_Node
=> User_Project_Node
,
2004 From_Project_Node_Tree
=> Project_Node_Tree
,
2006 Reset_Tree
=> Reset_Tree
,
2007 On_New_Tree_Loaded
=> On_New_Tree_Loaded
);
2010 Main_Project
:= No_Project
;
2015 if Project_Tree
.Source_Info_File_Name
/= null then
2016 if not Is_Absolute_Path
(Project_Tree
.Source_Info_File_Name
.all) then
2018 Obj_Dir
: constant Variable_Value
:=
2021 Main_Project
.Decl
.Attributes
,
2025 if Obj_Dir
= Nil_Variable_Value
or else Obj_Dir
.Default
then
2026 Get_Name_String
(Main_Project
.Directory
.Display_Name
);
2029 if Is_Absolute_Path
(Get_Name_String
(Obj_Dir
.Value
)) then
2030 Get_Name_String
(Obj_Dir
.Value
);
2034 Add_Str_To_Name_Buffer
2035 (Get_Name_String
(Main_Project
.Directory
.Display_Name
));
2036 Add_Str_To_Name_Buffer
(Get_Name_String
(Obj_Dir
.Value
));
2040 Add_Char_To_Name_Buffer
(Directory_Separator
);
2041 Add_Str_To_Name_Buffer
(Project_Tree
.Source_Info_File_Name
.all);
2042 Free
(Project_Tree
.Source_Info_File_Name
);
2043 Project_Tree
.Source_Info_File_Name
:=
2044 new String'(Name_Buffer (1 .. Name_Len));
2048 Read_Source_Info_File (Project_Tree);
2051 -- Get the first project that is not an aggregate project or an
2052 -- aggregate library project. The object directory of this project will
2053 -- be used to store the config project file in auto-configuration.
2055 Check_Project (Main_Project);
2057 -- Fail if there is only aggregate projects and aggregate library
2058 -- projects in the project tree.
2060 if Conf_Project = No_Project then
2061 Raise_Invalid_Config ("there are no non-aggregate projects");
2064 -- Find configuration file
2066 Get_Or_Create_Configuration_File
2067 (Config => Main_Config_Project,
2068 Project => Main_Project,
2069 Conf_Project => Conf_Project,
2070 Project_Tree => Project_Tree,
2071 Project_Node_Tree => Project_Node_Tree,
2073 Allow_Automatic_Generation => Allow_Automatic_Generation,
2074 Config_File_Name => Config_File_Name,
2075 Autoconf_Specified => Autoconf_Specified,
2076 Target_Name => Target_Name,
2077 Normalized_Hostname => Normalized_Hostname,
2078 Packages_To_Check => Packages_To_Check,
2079 Config_File_Path => Config_File_Path,
2080 Automatically_Generated => Automatically_Generated,
2081 On_Load_Config => On_Load_Config);
2083 Apply_Config_File (Main_Config_Project, Project_Tree);
2085 -- Finish processing the user's project
2087 Prj.Proc.Process_Project_Tree_Phase_2
2088 (In_Tree => Project_Tree,
2089 Project => Main_Project,
2091 From_Project_Node => User_Project_Node,
2092 From_Project_Node_Tree => Project_Node_Tree,
2096 if Project_Tree.Source_Info_File_Name /= null
2097 and then not Project_Tree.Source_Info_File_Exists
2099 Write_Source_Info_File (Project_Tree);
2103 Main_Project := No_Project;
2105 end Process_Project_And_Apply_Config;
2107 --------------------------
2108 -- Raise_Invalid_Config --
2109 --------------------------
2111 procedure Raise_Invalid_Config (Msg : String) is
2113 Raise_Exception (Invalid_Config'Identity, Msg);
2114 end Raise_Invalid_Config;
2116 ----------------------
2117 -- Runtime_Name_For --
2118 ----------------------
2120 function Runtime_Name_For (Language : Name_Id) return String is
2122 if RTS_Languages.Get (Language) /= No_Name then
2123 return Get_Name_String (RTS_Languages.Get (Language));
2127 end Runtime_Name_For;
2129 --------------------------
2130 -- Runtime_Name_Set_For --
2131 --------------------------
2133 function Runtime_Name_Set_For (Language : Name_Id) return Boolean is
2135 return RTS_Languages.Get (Language) /= No_Name;
2136 end Runtime_Name_Set_For;
2138 ---------------------
2139 -- Set_Runtime_For --
2140 ---------------------
2142 procedure Set_Runtime_For (Language : Name_Id; RTS_Name : String) is
2144 Name_Len := RTS_Name'Length;
2145 Name_Buffer (1 .. Name_Len) := RTS_Name;
2146 RTS_Languages.Set (Language, Name_Find);
2147 end Set_Runtime_For;
2149 ----------------------------
2150 -- Look_For_Project_Paths --
2151 ----------------------------
2153 procedure Look_For_Project_Paths
2154 (Project : Project_Id;
2155 Tree : Project_Tree_Ref;
2156 With_State : in out State)
2158 Lang_Id : Language_Ptr;
2159 Compiler_Root : Compiler_Root_Ptr;
2160 Runtime_Root : Runtime_Root_Ptr;
2161 Comp_Driver : String_Access;
2162 Comp_Dir : String_Access;
2163 Prefix : String_Access;
2165 pragma Unreferenced (Tree);
2168 With_State := No_State;
2170 Lang_Id := Project.Languages;
2171 while Lang_Id /= No_Language_Index loop
2172 if Lang_Id.Config.Compiler_Driver /= No_File then
2175 (Get_Name_String
(Lang_Id
.Config
.Compiler_Driver
));
2177 -- Get the absolute path of the compiler driver
2179 if not Is_Absolute_Path
(Comp_Driver
.all) then
2180 Comp_Driver
:= Locate_Exec_On_Path
(Comp_Driver
.all);
2183 if Comp_Driver
/= null and then Comp_Driver
'Length > 0 then
2186 (Containing_Directory (Comp_Driver.all));
2188 -- Consider only the compiler drivers that are in "bin"
2191 if Simple_Name (Comp_Dir.all) = "bin" then
2193 new String'(Containing_Directory
(Comp_Dir
.all));
2195 -- Check if the compiler root is already in the list. If it
2196 -- is not, add it to the list.
2198 Compiler_Root
:= First_Compiler_Root
;
2199 while Compiler_Root
/= null loop
2200 exit when Prefix
.all = Compiler_Root
.Root
.all;
2201 Compiler_Root
:= Compiler_Root
.Next
;
2204 if Compiler_Root
= null then
2205 First_Compiler_Root
:=
2206 new Compiler_Root_Data
'
2209 Next => First_Compiler_Root);
2210 Compiler_Root := First_Compiler_Root;
2213 -- If there is a runtime for this compiler, check if it is
2214 -- recorded with the compiler root. If it is not, record
2218 Runtime : constant String :=
2219 Runtime_Name_For (Lang_Id.Name);
2220 Root : String_Access;
2222 if Runtime'Length > 0 then
2223 if Is_Absolute_Path (Runtime) then
2224 Root := new String'(Runtime
);
2230 Directory_Separator &
2231 Opt.Target_Value.all &
2232 Directory_Separator &
2236 Runtime_Root := Compiler_Root.Runtimes;
2237 while Runtime_Root /= null loop
2238 exit when Root.all = Runtime_Root.Root.all;
2239 Runtime_Root := Runtime_Root.Next;
2242 if Runtime_Root = null then
2243 Compiler_Root.Runtimes :=
2244 new Runtime_Root_Data'
2246 Next
=> Compiler_Root
.Runtimes
);
2254 Lang_Id
:= Lang_Id
.Next
;
2256 end Look_For_Project_Paths
;