1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2006-2010, 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 ------------------------------------------------------------------------------
27 with Makeutl
; use Makeutl
;
30 with Output
; use Output
;
35 with Prj
.Proc
; use Prj
.Proc
;
36 with Prj
.Tree
; use Prj
.Tree
;
37 with Prj
.Util
; use Prj
.Util
;
39 with Snames
; use Snames
;
41 with Ada
.Directories
; use Ada
.Directories
;
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 Default_Name
: constant String := "default.cgpr";
51 -- Default configuration file that will be used if found
53 Config_Project_Env_Var
: constant String := "GPR_CONFIG";
54 -- Name of the environment variable that provides the name of the
55 -- configuration file to use.
57 Gprconfig_Name
: constant String := "gprconfig";
59 package RTS_Languages
is new GNAT
.HTable
.Simple_HTable
60 (Header_Num
=> Prj
.Header_Num
,
62 No_Element
=> No_Name
,
66 -- Stores the runtime names for the various languages. This is in general
67 -- set from a --RTS command line option.
69 procedure Add_Attributes
70 (Project_Tree
: Project_Tree_Ref
;
71 Conf_Decl
: Declarations
;
72 User_Decl
: in out Declarations
);
73 -- Process the attributes in the config declarations.
74 -- For single string values, if the attribute is not declared in the user
75 -- declarations, declare it with the value in the config declarations.
76 -- For string list values, prepend the value in the user declarations with
77 -- the value in the config declarations.
79 function Locate_Config_File
(Name
: String) return String_Access
;
80 -- Search for Name in the config files directory. Return full path if
81 -- found, or null otherwise
84 (Config_File
: Prj
.Project_Id
;
85 Autoconf_Specified
: Boolean;
86 Project_Tree
: Prj
.Project_Tree_Ref
;
87 Target
: String := "") return Boolean;
88 -- Check that the config file's target matches Target.
89 -- Target should be set to the empty string when the user did not specify
90 -- a target. If the target in the configuration file is invalid, this
91 -- function will raise Invalid_Config with an appropriate message.
92 -- Autoconf_Specified should be set to True if the user has used --autoconf
98 procedure Add_Attributes
99 (Project_Tree
: Project_Tree_Ref
;
100 Conf_Decl
: Declarations
;
101 User_Decl
: in out Declarations
)
103 Conf_Attr_Id
: Variable_Id
;
104 Conf_Attr
: Variable
;
105 Conf_Array_Id
: Array_Id
;
106 Conf_Array
: Array_Data
;
107 Conf_Array_Elem_Id
: Array_Element_Id
;
108 Conf_Array_Elem
: Array_Element
;
109 Conf_List
: String_List_Id
;
110 Conf_List_Elem
: String_Element
;
112 User_Attr_Id
: Variable_Id
;
113 User_Attr
: Variable
;
114 User_Array_Id
: Array_Id
;
115 User_Array
: Array_Data
;
116 User_Array_Elem_Id
: Array_Element_Id
;
117 User_Array_Elem
: Array_Element
;
120 Conf_Attr_Id
:= Conf_Decl
.Attributes
;
121 User_Attr_Id
:= User_Decl
.Attributes
;
122 while Conf_Attr_Id
/= No_Variable
loop
124 Project_Tree
.Variable_Elements
.Table
(Conf_Attr_Id
);
126 Project_Tree
.Variable_Elements
.Table
(User_Attr_Id
);
128 if not Conf_Attr
.Value
.Default
then
129 if User_Attr
.Value
.Default
then
131 -- No attribute declared in user project file: just copy the
132 -- value of the configuration attribute.
134 User_Attr
.Value
:= Conf_Attr
.Value
;
135 Project_Tree
.Variable_Elements
.Table
(User_Attr_Id
) :=
138 elsif User_Attr
.Value
.Kind
= List
139 and then Conf_Attr
.Value
.Values
/= Nil_String
141 -- List attribute declared in both the user project and the
142 -- configuration project: prepend the user list with the
143 -- configuration list.
146 Conf_List
: String_List_Id
:= Conf_Attr
.Value
.Values
;
147 Conf_Elem
: String_Element
;
148 User_List
: constant String_List_Id
:=
149 User_Attr
.Value
.Values
;
150 New_List
: String_List_Id
;
151 New_Elem
: String_Element
;
156 String_Element_Table
.Increment_Last
157 (Project_Tree
.String_Elements
);
158 New_List
:= String_Element_Table
.Last
159 (Project_Tree
.String_Elements
);
161 -- Value of attribute is new list
163 User_Attr
.Value
.Values
:= New_List
;
164 Project_Tree
.Variable_Elements
.Table
(User_Attr_Id
) :=
169 -- Get each element of configuration list
172 Project_Tree
.String_Elements
.Table
(Conf_List
);
173 New_Elem
:= Conf_Elem
;
174 Conf_List
:= Conf_Elem
.Next
;
176 if Conf_List
= Nil_String
then
178 -- If it is the last element in the list, connect to
179 -- first element of user list, and we are done.
181 New_Elem
.Next
:= User_List
;
182 Project_Tree
.String_Elements
.Table
183 (New_List
) := New_Elem
;
187 -- If it is not the last element in the list, add to
190 String_Element_Table
.Increment_Last
191 (Project_Tree
.String_Elements
);
193 String_Element_Table
.Last
194 (Project_Tree
.String_Elements
);
195 Project_Tree
.String_Elements
.Table
196 (New_List
) := New_Elem
;
197 New_List
:= New_Elem
.Next
;
204 Conf_Attr_Id
:= Conf_Attr
.Next
;
205 User_Attr_Id
:= User_Attr
.Next
;
208 Conf_Array_Id
:= Conf_Decl
.Arrays
;
209 while Conf_Array_Id
/= No_Array
loop
210 Conf_Array
:= Project_Tree
.Arrays
.Table
(Conf_Array_Id
);
212 User_Array_Id
:= User_Decl
.Arrays
;
213 while User_Array_Id
/= No_Array
loop
214 User_Array
:= Project_Tree
.Arrays
.Table
(User_Array_Id
);
215 exit when User_Array
.Name
= Conf_Array
.Name
;
216 User_Array_Id
:= User_Array
.Next
;
219 -- If this associative array does not exist in the user project file,
220 -- do a shallow copy of the full associative array.
222 if User_Array_Id
= No_Array
then
223 Array_Table
.Increment_Last
(Project_Tree
.Arrays
);
224 User_Array
:= Conf_Array
;
225 User_Array
.Next
:= User_Decl
.Arrays
;
226 User_Decl
.Arrays
:= Array_Table
.Last
(Project_Tree
.Arrays
);
227 Project_Tree
.Arrays
.Table
(User_Decl
.Arrays
) := User_Array
;
230 -- Otherwise, check each array element
232 Conf_Array_Elem_Id
:= Conf_Array
.Value
;
233 while Conf_Array_Elem_Id
/= No_Array_Element
loop
235 Project_Tree
.Array_Elements
.Table
(Conf_Array_Elem_Id
);
237 User_Array_Elem_Id
:= User_Array
.Value
;
238 while User_Array_Elem_Id
/= No_Array_Element
loop
240 Project_Tree
.Array_Elements
.Table
(User_Array_Elem_Id
);
241 exit when User_Array_Elem
.Index
= Conf_Array_Elem
.Index
;
242 User_Array_Elem_Id
:= User_Array_Elem
.Next
;
245 -- If the array element does not exist in the user array,
246 -- insert a shallow copy of the conf array element in the
249 if User_Array_Elem_Id
= No_Array_Element
then
250 Array_Element_Table
.Increment_Last
251 (Project_Tree
.Array_Elements
);
252 User_Array_Elem
:= Conf_Array_Elem
;
253 User_Array_Elem
.Next
:= User_Array
.Value
;
255 Array_Element_Table
.Last
(Project_Tree
.Array_Elements
);
256 Project_Tree
.Array_Elements
.Table
(User_Array
.Value
) :=
258 Project_Tree
.Arrays
.Table
(User_Array_Id
) := User_Array
;
260 -- Otherwise, if the value is a string list, prepend the
261 -- user array element with the conf array element value.
263 elsif Conf_Array_Elem
.Value
.Kind
= List
then
264 Conf_List
:= Conf_Array_Elem
.Value
.Values
;
266 if Conf_List
/= Nil_String
then
268 Link
: constant String_List_Id
:=
269 User_Array_Elem
.Value
.Values
;
270 Previous
: String_List_Id
:= Nil_String
;
271 Next
: String_List_Id
;
276 Project_Tree
.String_Elements
.Table
278 String_Element_Table
.Increment_Last
279 (Project_Tree
.String_Elements
);
281 String_Element_Table
.Last
282 (Project_Tree
.String_Elements
);
283 Project_Tree
.String_Elements
.Table
(Next
) :=
286 if Previous
= Nil_String
then
287 User_Array_Elem
.Value
.Values
:= Next
;
288 Project_Tree
.Array_Elements
.Table
289 (User_Array_Elem_Id
) := User_Array_Elem
;
292 Project_Tree
.String_Elements
.Table
293 (Previous
).Next
:= Next
;
298 Conf_List
:= Conf_List_Elem
.Next
;
300 if Conf_List
= Nil_String
then
301 Project_Tree
.String_Elements
.Table
302 (Previous
).Next
:= Link
;
310 Conf_Array_Elem_Id
:= Conf_Array_Elem
.Next
;
314 Conf_Array_Id
:= Conf_Array
.Next
;
318 ------------------------
319 -- Locate_Config_File --
320 ------------------------
322 function Locate_Config_File
(Name
: String) return String_Access
is
323 Prefix_Path
: constant String := Executable_Prefix_Path
;
325 if Prefix_Path
'Length /= 0 then
326 return Locate_Regular_File
328 "." & Path_Separator
&
329 Prefix_Path
& "share" & Directory_Separator
& "gpr");
331 return Locate_Regular_File
(Name
, ".");
333 end Locate_Config_File
;
339 function Check_Target
340 (Config_File
: Project_Id
;
341 Autoconf_Specified
: Boolean;
342 Project_Tree
: Prj
.Project_Tree_Ref
;
343 Target
: String := "") return Boolean
345 Variable
: constant Variable_Value
:=
347 (Name_Target
, Config_File
.Decl
.Attributes
, Project_Tree
);
348 Tgt_Name
: Name_Id
:= No_Name
;
352 if Variable
/= Nil_Variable_Value
and then not Variable
.Default
then
353 Tgt_Name
:= Variable
.Value
;
357 OK
:= not Autoconf_Specified
or else Tgt_Name
= No_Name
;
359 OK
:= Tgt_Name
/= No_Name
360 and then Target
= Get_Name_String
(Tgt_Name
);
364 if Autoconf_Specified
then
366 Write_Line
("inconsistent targets, performing autoconf");
372 if Tgt_Name
/= No_Name
then
374 with "invalid target name """
375 & Get_Name_String
(Tgt_Name
) & """ in configuration";
379 with "no target specified in configuration file";
387 --------------------------------------
388 -- Get_Or_Create_Configuration_File --
389 --------------------------------------
391 procedure Get_Or_Create_Configuration_File
392 (Project
: Project_Id
;
393 Project_Tree
: Project_Tree_Ref
;
394 Project_Node_Tree
: Prj
.Tree
.Project_Node_Tree_Ref
;
395 Allow_Automatic_Generation
: Boolean;
396 Config_File_Name
: String := "";
397 Autoconf_Specified
: Boolean;
398 Target_Name
: String := "";
399 Normalized_Hostname
: String;
400 Packages_To_Check
: String_List_Access
:= null;
401 Config
: out Prj
.Project_Id
;
402 Config_File_Path
: out String_Access
;
403 Automatically_Generated
: out Boolean;
404 Flags
: Processing_Flags
;
405 On_Load_Config
: Config_File_Hook
:= null)
407 function Default_File_Name
return String;
408 -- Return the name of the default config file that should be tested
410 procedure Do_Autoconf
;
411 -- Generate a new config file through gprconfig.
412 -- In case of error, this raises the Invalid_Config exception with an
413 -- appropriate message
415 function Get_Config_Switches
return Argument_List_Access
;
416 -- Return the --config switches to use for gprconfig
418 function Might_Have_Sources
(Project
: Project_Id
) return Boolean;
419 -- True if the specified project might have sources (ie the user has not
420 -- explicitly specified it. We haven't checked the file system, nor do
421 -- we need to at this stage.
423 -----------------------
424 -- Default_File_Name --
425 -----------------------
427 function Default_File_Name
return String is
428 Ada_RTS
: constant String := Runtime_Name_For
(Name_Ada
);
432 if Target_Name
/= "" then
433 if Ada_RTS
/= "" then
434 return Target_Name
& '-' & Ada_RTS
435 & Config_Project_File_Extension
;
437 return Target_Name
& Config_Project_File_Extension
;
440 elsif Ada_RTS
/= "" then
441 return Ada_RTS
& Config_Project_File_Extension
;
444 Tmp
:= Getenv
(Config_Project_Env_Var
);
447 T
: constant String := Tmp
.all;
458 end Default_File_Name
;
460 ------------------------
461 -- Might_Have_Sources --
462 ------------------------
464 function Might_Have_Sources
(Project
: Project_Id
) return Boolean is
465 Variable
: Variable_Value
;
471 Project
.Decl
.Attributes
,
474 if Variable
= Nil_Variable_Value
475 or else Variable
.Default
476 or else Variable
.Values
/= Nil_String
481 Project
.Decl
.Attributes
,
483 return Variable
= Nil_Variable_Value
484 or else Variable
.Default
485 or else Variable
.Values
/= Nil_String
;
490 end Might_Have_Sources
;
492 -------------------------
493 -- Get_Config_Switches --
494 -------------------------
496 function Get_Config_Switches
return Argument_List_Access
is
497 package Language_Htable
is new GNAT
.HTable
.Simple_HTable
498 (Header_Num
=> Prj
.Header_Num
,
500 No_Element
=> No_Name
,
504 -- Hash table to keep the languages used in the project tree
506 IDE
: constant Package_Id
:=
509 Project
.Decl
.Packages
,
512 Prj_Iter
: Project_List
;
513 List
: String_List_Id
;
514 Elem
: String_Element
;
516 Variable
: Variable_Value
;
519 Result
: Argument_List_Access
;
521 Check_Default
: Boolean;
524 Prj_Iter
:= Project_Tree
.Projects
;
525 while Prj_Iter
/= null loop
526 if Might_Have_Sources
(Prj_Iter
.Project
) then
530 Prj_Iter
.Project
.Decl
.Attributes
,
533 if Variable
= Nil_Variable_Value
534 or else Variable
.Default
536 -- Languages is not declared. If it is not an extending
537 -- project, or if it extends a project with no Languages,
538 -- check for Default_Language.
540 Check_Default
:= Prj_Iter
.Project
.Extends
= No_Project
;
542 if not Check_Default
then
546 Prj_Iter
.Project
.Extends
.Decl
.Attributes
,
549 Variable
/= Nil_Variable_Value
550 and then Variable
.Values
= Nil_String
;
553 if Check_Default
then
556 (Name_Default_Language
,
557 Prj_Iter
.Project
.Decl
.Attributes
,
560 if Variable
/= Nil_Variable_Value
561 and then not Variable
.Default
563 Get_Name_String
(Variable
.Value
);
564 To_Lower
(Name_Buffer
(1 .. Name_Len
));
566 Language_Htable
.Set
(Lang
, Lang
);
569 -- If no default language is declared, default to Ada
571 Language_Htable
.Set
(Name_Ada
, Name_Ada
);
575 elsif Variable
.Values
/= Nil_String
then
577 -- Attribute Languages is declared with a non empty
578 -- list: put all the languages in Language_HTable.
580 List
:= Variable
.Values
;
581 while List
/= Nil_String
loop
582 Elem
:= Project_Tree
.String_Elements
.Table
(List
);
584 Get_Name_String
(Elem
.Value
);
585 To_Lower
(Name_Buffer
(1 .. Name_Len
));
587 Language_Htable
.Set
(Lang
, Lang
);
594 Prj_Iter
:= Prj_Iter
.Next
;
597 Name
:= Language_Htable
.Get_First
;
599 while Name
/= No_Name
loop
601 Name
:= Language_Htable
.Get_Next
;
604 Result
:= new String_List
(1 .. Count
);
607 Name
:= Language_Htable
.Get_First
;
608 while Name
/= No_Name
loop
609 -- Check if IDE'Compiler_Command is declared for the language.
610 -- If it is, use its value to invoke gprconfig.
615 Attribute_Or_Array_Name
=> Name_Compiler_Command
,
617 In_Tree
=> Project_Tree
,
618 Force_Lower_Case_Index
=> True);
621 Config_Command
: constant String :=
622 "--config=" & Get_Name_String
(Name
);
624 Runtime_Name
: constant String :=
625 Runtime_Name_For
(Name
);
628 if Variable
= Nil_Variable_Value
629 or else Length_Of_Name
(Variable
.Value
) = 0
632 new String'(Config_Command & ",," & Runtime_Name);
636 Compiler_Command : constant String :=
637 Get_Name_String (Variable.Value);
640 if Is_Absolute_Path (Compiler_Command) then
643 (Config_Command
& ",," & Runtime_Name
& "," &
644 Containing_Directory
(Compiler_Command
) & "," &
645 Simple_Name
(Compiler_Command
));
649 (Config_Command & ",," & Runtime_Name & ",," &
657 Name := Language_Htable.Get_Next;
661 end Get_Config_Switches;
667 procedure Do_Autoconf is
668 Obj_Dir : constant Variable_Value :=
671 Project.Decl.Attributes,
674 Gprconfig_Path : String_Access;
678 Gprconfig_Path := Locate_Exec_On_Path (Gprconfig_Name);
680 if Gprconfig_Path = null then
682 with "could not locate gprconfig for auto-configuration";
685 -- First, find the object directory of the user's project
687 if Obj_Dir = Nil_Variable_Value or else Obj_Dir.Default then
688 Get_Name_String (Project.Directory.Name);
691 if Is_Absolute_Path (Get_Name_String (Obj_Dir.Value)) then
692 Get_Name_String (Obj_Dir.Value);
696 Add_Str_To_Name_Buffer
697 (Get_Name_String (Project.Directory.Name));
698 Add_Str_To_Name_Buffer (Get_Name_String (Obj_Dir.Value));
702 if Subdirs /= null then
703 Add_Char_To_Name_Buffer (Directory_Separator);
704 Add_Str_To_Name_Buffer (Subdirs.all);
707 for J in 1 .. Name_Len loop
708 if Name_Buffer (J) = '/' then
709 Name_Buffer (J) := Directory_Separator;
714 Obj_Dir : constant String := Name_Buffer (1 .. Name_Len);
715 Switches : Argument_List_Access := Get_Config_Switches;
716 Args : Argument_List (1 .. 5);
719 Obj_Dir_Exists : Boolean := True;
722 -- Check if the object directory exists. If Setup_Projects is True
723 -- (-p) and directory does not exist, attempt to create it.
724 -- Otherwise, if directory does not exist, fail without calling
727 if not Is_Directory (Obj_Dir)
728 and then (Setup_Projects or else Subdirs /= null)
731 Create_Path (Obj_Dir);
733 if not Quiet_Output then
734 Write_Str ("object directory """);
736 Write_Line (""" created");
742 with "could not create object directory " & Obj_Dir;
746 if not Is_Directory (Obj_Dir) then
747 case Flags.Require_Obj_Dirs is
750 with "object directory " & Obj_Dir & " does not exist";
754 "?object directory " & Obj_Dir & " does not exist");
755 Obj_Dir_Exists := False;
763 Args (1) := new String'("--batch");
764 Args
(2) := new String'("-o");
766 -- If no config file was specified, set the auto.cgpr one
768 if Config_File_Name = "" then
769 if Obj_Dir_Exists then
771 new String'(Obj_Dir
& Directory_Separator
& Auto_Cgpr
);
775 Path_FD
: File_Descriptor
;
776 Path_Name
: Path_Name_Type
;
779 Prj
.Env
.Create_Temp_File
780 (In_Tree
=> Project_Tree
,
782 Path_Name
=> Path_Name
,
783 File_Use
=> "configuration file");
785 if Path_FD
/= Invalid_FD
then
786 Args
(3) := new String'(Get_Name_String (Path_Name));
787 GNAT.OS_Lib.Close (Path_FD);
790 -- We'll have an error message later on
794 (Obj_Dir
& Directory_Separator
& Auto_Cgpr
);
799 Args
(3) := new String'(Config_File_Name);
802 if Normalized_Hostname = "" then
805 if Target_Name = "" then
806 Args (4) := new String'("--target=" & Normalized_Hostname
);
808 Args
(4) := new String'("--target=" & Target_Name);
814 if not Verbose_Mode then
815 Arg_Last := Arg_Last + 1;
816 Args (Arg_Last) := new String'("-q");
820 Write_Str
(Gprconfig_Name
);
822 for J
in 1 .. Arg_Last
loop
824 Write_Str
(Args
(J
).all);
827 for J
in Switches
'Range loop
829 Write_Str
(Switches
(J
).all);
834 elsif not Quiet_Output
then
835 -- Display no message if we are creating auto.cgpr, unless in
838 if Config_File_Name
/= ""
841 Write_Str
("creating ");
842 Write_Str
(Simple_Name
(Args
(3).all));
847 Spawn
(Gprconfig_Path
.all, Args
(1 .. Arg_Last
) & Switches
.all,
852 Config_File_Path
:= Locate_Config_File
(Args
(3).all);
854 if Config_File_Path
= null then
856 with "could not create " & Args
(3).all;
859 for F
in Args
'Range loop
866 Config_Project_Node
: Project_Node_Id
:= Empty_Node
;
869 Free
(Config_File_Path
);
870 Config
:= No_Project
;
872 if Config_File_Name
/= "" then
873 Config_File_Path
:= Locate_Config_File
(Config_File_Name
);
875 Config_File_Path
:= Locate_Config_File
(Default_File_Name
);
878 if Config_File_Path
= null then
879 if (not Allow_Automatic_Generation
) and then
880 Config_File_Name
/= ""
883 with "could not locate main configuration project "
888 Automatically_Generated
:=
889 Allow_Automatic_Generation
and then Config_File_Path
= null;
891 <<Process_Config_File
>>
893 if Automatically_Generated
then
894 if Hostparm
.OpenVMS
then
896 -- There is no gprconfig on VMS
899 with "could not locate any configuration project file";
902 -- This might raise an Invalid_Config exception
908 -- Parse the configuration file
910 if Verbose_Mode
and then Config_File_Path
/= null then
911 Write_Str
("Checking configuration ");
912 Write_Line
(Config_File_Path
.all);
915 if Config_File_Path
/= null then
917 (In_Tree
=> Project_Node_Tree
,
918 Project
=> Config_Project_Node
,
919 Project_File_Name
=> Config_File_Path
.all,
920 Always_Errout_Finalize
=> False,
921 Packages_To_Check
=> Packages_To_Check
,
922 Current_Directory
=> Current_Directory
,
923 Is_Config_File
=> True,
926 -- Maybe the user will want to create his own configuration file
927 Config_Project_Node
:= Empty_Node
;
930 if On_Load_Config
/= null then
932 (Config_File
=> Config_Project_Node
,
933 Project_Node_Tree
=> Project_Node_Tree
);
936 if Config_Project_Node
/= Empty_Node
then
937 Prj
.Proc
.Process_Project_Tree_Phase_1
938 (In_Tree
=> Project_Tree
,
941 From_Project_Node
=> Config_Project_Node
,
942 From_Project_Node_Tree
=> Project_Node_Tree
,
944 Reset_Tree
=> False);
947 if Config_Project_Node
= Empty_Node
948 or else Config
= No_Project
951 with "processing of configuration project """
952 & Config_File_Path
.all & """ failed";
955 -- Check that the target of the configuration file is the one the user
956 -- specified on the command line. We do not need to check that when in
957 -- auto-conf mode, since the appropriate target was passed to gprconfig.
959 if not Automatically_Generated
961 Check_Target
(Config
, Autoconf_Specified
, Project_Tree
, Target_Name
)
963 Automatically_Generated
:= True;
964 goto Process_Config_File
;
966 end Get_Or_Create_Configuration_File
;
968 --------------------------------------
969 -- Process_Project_And_Apply_Config --
970 --------------------------------------
972 procedure Process_Project_And_Apply_Config
973 (Main_Project
: out Prj
.Project_Id
;
974 User_Project_Node
: Prj
.Tree
.Project_Node_Id
;
975 Config_File_Name
: String := "";
976 Autoconf_Specified
: Boolean;
977 Project_Tree
: Prj
.Project_Tree_Ref
;
978 Project_Node_Tree
: Prj
.Tree
.Project_Node_Tree_Ref
;
979 Packages_To_Check
: String_List_Access
;
980 Allow_Automatic_Generation
: Boolean := True;
981 Automatically_Generated
: out Boolean;
982 Config_File_Path
: out String_Access
;
983 Target_Name
: String := "";
984 Normalized_Hostname
: String;
985 Flags
: Processing_Flags
;
986 On_Load_Config
: Config_File_Hook
:= null;
987 Reset_Tree
: Boolean := True)
989 Main_Config_Project
: Project_Id
;
993 Main_Project
:= No_Project
;
994 Automatically_Generated
:= False;
996 Process_Project_Tree_Phase_1
997 (In_Tree
=> Project_Tree
,
998 Project
=> Main_Project
,
1000 From_Project_Node
=> User_Project_Node
,
1001 From_Project_Node_Tree
=> Project_Node_Tree
,
1003 Reset_Tree
=> Reset_Tree
);
1006 Main_Project
:= No_Project
;
1010 -- Find configuration file
1012 Get_Or_Create_Configuration_File
1013 (Config
=> Main_Config_Project
,
1014 Project
=> Main_Project
,
1015 Project_Tree
=> Project_Tree
,
1016 Project_Node_Tree
=> Project_Node_Tree
,
1017 Allow_Automatic_Generation
=> Allow_Automatic_Generation
,
1018 Config_File_Name
=> Config_File_Name
,
1019 Autoconf_Specified
=> Autoconf_Specified
,
1020 Target_Name
=> Target_Name
,
1021 Normalized_Hostname
=> Normalized_Hostname
,
1022 Packages_To_Check
=> Packages_To_Check
,
1023 Config_File_Path
=> Config_File_Path
,
1024 Automatically_Generated
=> Automatically_Generated
,
1026 On_Load_Config
=> On_Load_Config
);
1028 Apply_Config_File
(Main_Config_Project
, Project_Tree
);
1030 -- Finish processing the user's project
1032 Prj
.Proc
.Process_Project_Tree_Phase_2
1033 (In_Tree
=> Project_Tree
,
1034 Project
=> Main_Project
,
1036 From_Project_Node
=> User_Project_Node
,
1037 From_Project_Node_Tree
=> Project_Node_Tree
,
1041 Main_Project
:= No_Project
;
1043 end Process_Project_And_Apply_Config
;
1045 ------------------------------------
1046 -- Parse_Project_And_Apply_Config --
1047 ------------------------------------
1049 procedure Parse_Project_And_Apply_Config
1050 (Main_Project
: out Prj
.Project_Id
;
1051 User_Project_Node
: out Prj
.Tree
.Project_Node_Id
;
1052 Config_File_Name
: String := "";
1053 Autoconf_Specified
: Boolean;
1054 Project_File_Name
: String;
1055 Project_Tree
: Prj
.Project_Tree_Ref
;
1056 Project_Node_Tree
: Prj
.Tree
.Project_Node_Tree_Ref
;
1057 Packages_To_Check
: String_List_Access
;
1058 Allow_Automatic_Generation
: Boolean := True;
1059 Automatically_Generated
: out Boolean;
1060 Config_File_Path
: out String_Access
;
1061 Target_Name
: String := "";
1062 Normalized_Hostname
: String;
1063 Flags
: Processing_Flags
;
1064 On_Load_Config
: Config_File_Hook
:= null)
1067 -- Parse the user project tree
1069 Prj
.Initialize
(Project_Tree
);
1071 Main_Project
:= No_Project
;
1072 Automatically_Generated
:= False;
1075 (In_Tree
=> Project_Node_Tree
,
1076 Project
=> User_Project_Node
,
1077 Project_File_Name
=> Project_File_Name
,
1078 Always_Errout_Finalize
=> False,
1079 Packages_To_Check
=> Packages_To_Check
,
1080 Current_Directory
=> Current_Directory
,
1081 Is_Config_File
=> False,
1084 if User_Project_Node
= Empty_Node
then
1085 User_Project_Node
:= Empty_Node
;
1089 Process_Project_And_Apply_Config
1090 (Main_Project
=> Main_Project
,
1091 User_Project_Node
=> User_Project_Node
,
1092 Config_File_Name
=> Config_File_Name
,
1093 Autoconf_Specified
=> Autoconf_Specified
,
1094 Project_Tree
=> Project_Tree
,
1095 Project_Node_Tree
=> Project_Node_Tree
,
1096 Packages_To_Check
=> Packages_To_Check
,
1097 Allow_Automatic_Generation
=> Allow_Automatic_Generation
,
1098 Automatically_Generated
=> Automatically_Generated
,
1099 Config_File_Path
=> Config_File_Path
,
1100 Target_Name
=> Target_Name
,
1101 Normalized_Hostname
=> Normalized_Hostname
,
1103 On_Load_Config
=> On_Load_Config
);
1104 end Parse_Project_And_Apply_Config
;
1106 -----------------------
1107 -- Apply_Config_File --
1108 -----------------------
1110 procedure Apply_Config_File
1111 (Config_File
: Prj
.Project_Id
;
1112 Project_Tree
: Prj
.Project_Tree_Ref
)
1114 Conf_Decl
: constant Declarations
:= Config_File
.Decl
;
1115 Conf_Pack_Id
: Package_Id
;
1116 Conf_Pack
: Package_Element
;
1118 User_Decl
: Declarations
;
1119 User_Pack_Id
: Package_Id
;
1120 User_Pack
: Package_Element
;
1121 Proj
: Project_List
;
1124 Proj
:= Project_Tree
.Projects
;
1125 while Proj
/= null loop
1126 if Proj
.Project
/= Config_File
then
1127 User_Decl
:= Proj
.Project
.Decl
;
1129 (Project_Tree
=> Project_Tree
,
1130 Conf_Decl
=> Conf_Decl
,
1131 User_Decl
=> User_Decl
);
1133 Conf_Pack_Id
:= Conf_Decl
.Packages
;
1134 while Conf_Pack_Id
/= No_Package
loop
1135 Conf_Pack
:= Project_Tree
.Packages
.Table
(Conf_Pack_Id
);
1137 User_Pack_Id
:= User_Decl
.Packages
;
1138 while User_Pack_Id
/= No_Package
loop
1139 User_Pack
:= Project_Tree
.Packages
.Table
(User_Pack_Id
);
1140 exit when User_Pack
.Name
= Conf_Pack
.Name
;
1141 User_Pack_Id
:= User_Pack
.Next
;
1144 if User_Pack_Id
= No_Package
then
1145 Package_Table
.Increment_Last
(Project_Tree
.Packages
);
1146 User_Pack
:= Conf_Pack
;
1147 User_Pack
.Next
:= User_Decl
.Packages
;
1148 User_Decl
.Packages
:=
1149 Package_Table
.Last
(Project_Tree
.Packages
);
1150 Project_Tree
.Packages
.Table
(User_Decl
.Packages
) :=
1155 (Project_Tree
=> Project_Tree
,
1156 Conf_Decl
=> Conf_Pack
.Decl
,
1157 User_Decl
=> Project_Tree
.Packages
.Table
1158 (User_Pack_Id
).Decl
);
1161 Conf_Pack_Id
:= Conf_Pack
.Next
;
1164 Proj
.Project
.Decl
:= User_Decl
;
1169 end Apply_Config_File
;
1171 ---------------------
1172 -- Set_Runtime_For --
1173 ---------------------
1175 procedure Set_Runtime_For
(Language
: Name_Id
; RTS_Name
: String) is
1177 Name_Len
:= RTS_Name
'Length;
1178 Name_Buffer
(1 .. Name_Len
) := RTS_Name
;
1179 RTS_Languages
.Set
(Language
, Name_Find
);
1180 end Set_Runtime_For
;
1182 ----------------------
1183 -- Runtime_Name_For --
1184 ----------------------
1186 function Runtime_Name_For
(Language
: Name_Id
) return String is
1188 if RTS_Languages
.Get
(Language
) /= No_Name
then
1189 return Get_Name_String
(RTS_Languages
.Get
(Language
));
1193 end Runtime_Name_For
;
1195 ------------------------------------
1196 -- Add_Default_GNAT_Naming_Scheme --
1197 ------------------------------------
1199 procedure Add_Default_GNAT_Naming_Scheme
1200 (Config_File
: in out Project_Node_Id
;
1201 Project_Tree
: Project_Node_Tree_Ref
)
1203 procedure Create_Attribute
1206 Index
: String := "";
1207 Pkg
: Project_Node_Id
:= Empty_Node
);
1209 ----------------------
1210 -- Create_Attribute --
1211 ----------------------
1213 procedure Create_Attribute
1216 Index
: String := "";
1217 Pkg
: Project_Node_Id
:= Empty_Node
)
1219 Attr
: Project_Node_Id
;
1220 pragma Unreferenced
(Attr
);
1222 Expr
: Name_Id
:= No_Name
;
1223 Val
: Name_Id
:= No_Name
;
1224 Parent
: Project_Node_Id
:= Config_File
;
1227 Name_Len
:= Index
'Length;
1228 Name_Buffer
(1 .. Name_Len
) := Index
;
1232 if Pkg
/= Empty_Node
then
1236 Name_Len
:= Value
'Length;
1237 Name_Buffer
(1 .. Name_Len
) := Value
;
1240 Attr
:= Create_Attribute
1241 (Tree
=> Project_Tree
,
1242 Prj_Or_Pkg
=> Parent
,
1246 Value
=> Create_Literal_String
(Expr
, Project_Tree
));
1247 end Create_Attribute
;
1252 Naming
: Project_Node_Id
;
1254 -- Start of processing for Add_Default_GNAT_Naming_Scheme
1257 if Config_File
= Empty_Node
then
1259 -- Create a dummy config file is none was found
1261 Name_Len
:= Auto_Cgpr
'Length;
1262 Name_Buffer
(1 .. Name_Len
) := Auto_Cgpr
;
1265 -- An invalid project name to avoid conflicts with user-created ones
1268 Name_Buffer
(1 .. Name_Len
) := "_auto";
1272 (In_Tree
=> Project_Tree
,
1274 Full_Path
=> Path_Name_Type
(Name
),
1275 Is_Config_File
=> True);
1277 -- Setup library support
1279 case MLib
.Tgt
.Support_For_Libraries
is
1284 Create_Attribute
(Name_Library_Support
, "static_only");
1287 Create_Attribute
(Name_Library_Support
, "full");
1290 if MLib
.Tgt
.Standalone_Library_Auto_Init_Is_Supported
then
1291 Create_Attribute
(Name_Library_Auto_Init_Supported
, "true");
1293 Create_Attribute
(Name_Library_Auto_Init_Supported
, "false");
1296 -- Setup Ada support (Ada is the default language here, since this
1297 -- is only called when no config file existed initially, ie for
1300 Create_Attribute
(Name_Default_Language
, "ada");
1302 Naming
:= Create_Package
(Project_Tree
, Config_File
, "naming");
1303 Create_Attribute
(Name_Spec_Suffix
, ".ads", "ada", Pkg
=> Naming
);
1304 Create_Attribute
(Name_Separate_Suffix
, ".adb", "ada", Pkg
=> Naming
);
1305 Create_Attribute
(Name_Body_Suffix
, ".adb", "ada", Pkg
=> Naming
);
1306 Create_Attribute
(Name_Dot_Replacement
, "-", Pkg
=> Naming
);
1307 Create_Attribute
(Name_Casing
, "lowercase", Pkg
=> Naming
);
1309 if Current_Verbosity
= High
then
1310 Write_Line
("Automatically generated (in-memory) config file");
1312 (Project
=> Config_File
,
1313 In_Tree
=> Project_Tree
,
1314 Backward_Compatibility
=> False);
1317 end Add_Default_GNAT_Naming_Scheme
;