===================================================================
@@ -1255,9 +1255,101 @@ package body Prj.Proc is
Pkg : Package_Id;
Item : Project_Node_Id)
is
+ procedure Check_Or_Set_Typed_Variable
+ (Value : in out Variable_Value;
+ Declaration : Project_Node_Id);
+ -- Check whether Value is valid for this typed variable declaration. If
+ -- it is an error, the behavior depends on the flags: either an error is
+ -- reported, or a warning, or nothing. In the last two cases, the value
+ -- of the variable is set to a valid value, replacing Value.
+
+ ---------------------------------
+ -- Check_Or_Set_Typed_Variable --
+ ---------------------------------
+
+ procedure Check_Or_Set_Typed_Variable
+ (Value : in out Variable_Value;
+ Declaration : Project_Node_Id)
+ is
+ Loc : constant Source_Ptr :=
+ Location_Of (Declaration, From_Project_Node_Tree);
+
+ Reset_Value : Boolean := False;
+ Current_String : Project_Node_Id;
+
+ begin
+ -- Report an error for an empty string
+
+ if Value.Value = Empty_String then
+ Error_Msg_Name_1 := Name_Of (Declaration, From_Project_Node_Tree);
+
+ case Flags.Allow_Invalid_External is
+ when Error =>
+ Error_Msg (Flags, "no value defined for %%", Loc, Project);
+ when Warning =>
+ Reset_Value := True;
+ Error_Msg (Flags, "?no value defined for %%", Loc, Project);
+ when Silent =>
+ Reset_Value := True;
+ end case;
+
+ else
+ -- Loop through all the valid strings for the
+ -- string type and compare to the string value.
+
+ Current_String :=
+ First_Literal_String
+ (String_Type_Of (Declaration, From_Project_Node_Tree),
+ From_Project_Node_Tree);
+ while Present (Current_String)
+ and then String_Value_Of
+ (Current_String, From_Project_Node_Tree) /= Value.Value
+ loop
+ Current_String :=
+ Next_Literal_String (Current_String, From_Project_Node_Tree);
+ end loop;
+
+ -- Report error if string value is not one for the string type
+
+ if No (Current_String) then
+ Error_Msg_Name_1 := Value.Value;
+ Error_Msg_Name_2 :=
+ Name_Of (Declaration, From_Project_Node_Tree);
+
+ case Flags.Allow_Invalid_External is
+ when Error =>
+ Error_Msg
+ (Flags, "value %% is illegal for typed string %%",
+ Loc, Project);
+ when Warning =>
+ Error_Msg
+ (Flags, "?value %% is illegal for typed string %%",
+ Loc, Project);
+ Reset_Value := True;
+ when Silent =>
+ Reset_Value := True;
+ end case;
+ end if;
+ end if;
+
+ if Reset_Value then
+ Current_String :=
+ First_Literal_String
+ (String_Type_Of (Declaration, From_Project_Node_Tree),
+ From_Project_Node_Tree);
+
+ Value.Value := String_Value_Of
+ (Current_String, From_Project_Node_Tree);
+ end if;
+ end Check_Or_Set_Typed_Variable;
+
+ -- Local variables
+
Current_Declarative_Item : Project_Node_Id;
Current_Item : Project_Node_Id;
+ -- Start of processing for Process_Declarative_Items
+
begin
-- Loop through declarative items
@@ -1677,7 +1769,7 @@ package body Prj.Proc is
else
declare
- New_Value : constant Variable_Value :=
+ New_Value : Variable_Value :=
Expression
(Project => Project,
In_Tree => In_Tree,
@@ -1713,59 +1805,9 @@ package body Prj.Proc is
if Kind_Of (Current_Item, From_Project_Node_Tree) =
N_Typed_Variable_Declaration
then
- -- Report an error for an empty string
-
- if New_Value.Value = Empty_String then
- Error_Msg_Name_1 :=
- Name_Of (Current_Item, From_Project_Node_Tree);
- Error_Msg
- (Flags,
- "no value defined for %%",
- Location_Of
- (Current_Item, From_Project_Node_Tree),
- Project);
-
- else
- declare
- Current_String : Project_Node_Id;
-
- begin
- -- Loop through all the valid strings for the
- -- string type and compare to the string value.
-
- Current_String :=
- First_Literal_String
- (String_Type_Of (Current_Item,
- From_Project_Node_Tree),
- From_Project_Node_Tree);
- while Present (Current_String)
- and then
- String_Value_Of
- (Current_String, From_Project_Node_Tree) /=
- New_Value.Value
- loop
- Current_String :=
- Next_Literal_String
- (Current_String, From_Project_Node_Tree);
- end loop;
-
- -- Report an error if the string value is not
- -- one for the string type.
-
- if No (Current_String) then
- Error_Msg_Name_1 := New_Value.Value;
- Error_Msg_Name_2 :=
- Name_Of
- (Current_Item, From_Project_Node_Tree);
- Error_Msg
- (Flags,
- "value %% is illegal for typed string %%",
- Location_Of
- (Current_Item, From_Project_Node_Tree),
- Project);
- end if;
- end;
- end if;
+ Check_Or_Set_Typed_Variable
+ (Value => New_Value,
+ Declaration => Current_Item);
end if;
-- Comment here ???
===================================================================
@@ -1230,7 +1230,8 @@ package body Prj is
Allow_Duplicate_Basenames : Boolean := True;
Compiler_Driver_Mandatory : Boolean := False;
Error_On_Unknown_Language : Boolean := True;
- Require_Obj_Dirs : Error_Warning := Error)
+ Require_Obj_Dirs : Error_Warning := Error;
+ Allow_Invalid_External : Error_Warning := Error)
return Processing_Flags
is
begin
@@ -1241,7 +1242,8 @@ package body Prj is
Allow_Duplicate_Basenames => Allow_Duplicate_Basenames,
Error_On_Unknown_Language => Error_On_Unknown_Language,
Compiler_Driver_Mandatory => Compiler_Driver_Mandatory,
- Require_Obj_Dirs => Require_Obj_Dirs);
+ Require_Obj_Dirs => Require_Obj_Dirs,
+ Allow_Invalid_External => Allow_Invalid_External);
end Create_Flags;
------------
===================================================================
@@ -1452,7 +1452,8 @@ package Prj is
Allow_Duplicate_Basenames : Boolean := True;
Compiler_Driver_Mandatory : Boolean := False;
Error_On_Unknown_Language : Boolean := True;
- Require_Obj_Dirs : Error_Warning := Error)
+ Require_Obj_Dirs : Error_Warning := Error;
+ Allow_Invalid_External : Error_Warning := Error)
return Processing_Flags;
-- Function used to create Processing_Flags structure
--
@@ -1481,6 +1482,10 @@ package Prj is
-- If Require_Obj_Dirs is true, then all object directories must exist
-- (possibly after they have been created automatically if the appropriate
-- switches were specified), or an error is raised.
+ --
+ -- If Allow_Invalid_External is Silent, then no error is reported when an
+ -- invalid value is used for an external variable (and it doesn't match its
+ -- type). Instead, the first possible value is used.
Gprbuild_Flags : constant Processing_Flags;
Gprclean_Flags : constant Processing_Flags;
@@ -1589,6 +1594,7 @@ private
Compiler_Driver_Mandatory : Boolean;
Error_On_Unknown_Language : Boolean;
Require_Obj_Dirs : Error_Warning;
+ Allow_Invalid_External : Error_Warning;
end record;
Gprbuild_Flags : constant Processing_Flags :=
@@ -1598,7 +1604,8 @@ private
Allow_Duplicate_Basenames => False,
Compiler_Driver_Mandatory => True,
Error_On_Unknown_Language => True,
- Require_Obj_Dirs => Error);
+ Require_Obj_Dirs => Error,
+ Allow_Invalid_External => Error);
Gprclean_Flags : constant Processing_Flags :=
(Report_Error => null,
@@ -1607,7 +1614,8 @@ private
Allow_Duplicate_Basenames => False,
Compiler_Driver_Mandatory => True,
Error_On_Unknown_Language => True,
- Require_Obj_Dirs => Warning);
+ Require_Obj_Dirs => Warning,
+ Allow_Invalid_External => Error);
Gnatmake_Flags : constant Processing_Flags :=
(Report_Error => null,
@@ -1616,6 +1624,7 @@ private
Allow_Duplicate_Basenames => False,
Compiler_Driver_Mandatory => False,
Error_On_Unknown_Language => False,
- Require_Obj_Dirs => Error);
+ Require_Obj_Dirs => Error,
+ Allow_Invalid_External => Error);
end Prj;