From patchwork Thu Jun 17 07:11:58 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 55976 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 21433B7D98 for ; Thu, 17 Jun 2010 17:11:58 +1000 (EST) Received: (qmail 5483 invoked by alias); 17 Jun 2010 07:11:54 -0000 Received: (qmail 5466 invoked by uid 22791); 17 Jun 2010 07:11:50 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL, BAYES_00, TW_PR, T_RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from mel.act-europe.fr (HELO mel.act-europe.fr) (212.99.106.210) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Thu, 17 Jun 2010 07:11:43 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id 7C669CB0254; Thu, 17 Jun 2010 09:11:48 +0200 (CEST) Received: from mel.act-europe.fr ([127.0.0.1]) by localhost (smtp.eu.adacore.com [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id 9j9AhESgTbIM; Thu, 17 Jun 2010 09:11:48 +0200 (CEST) Received: from saumur.act-europe.fr (saumur.act-europe.fr [10.10.0.183]) by mel.act-europe.fr (Postfix) with ESMTP id 5A1CFCB01D7; Thu, 17 Jun 2010 09:11:48 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id 43B82D87F0; Thu, 17 Jun 2010 09:11:58 +0200 (CEST) Date: Thu, 17 Jun 2010 09:11:58 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Emmanuel Briot Subject: [Ada] behavior of invalid typed variable in project files Message-ID: <20100617071158.GA24675@adacore.com> Mime-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.9i X-IsSubscribed: yes Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org When parsing a project file, an invalid value given to a typed variable, in particular when this value comes from the environment, is no longer systematically fatal. In several contexts (IDEs...) we still want to manipulate the project. A new flag was introduced to control this behavior. Tested on x86_64-pc-linux-gnu, committed on trunk 2010-06-17 Emmanuel Briot * prj-proc.adb, prj.adb, prj.ads (Check_Or_Set_Typed_Variable): New subprogram. (Process_Declarative_Item): An invalid value in an typed variable declaration is no longer always fatal. Index: prj-proc.adb =================================================================== --- prj-proc.adb (revision 160834) +++ prj-proc.adb (working copy) @@ -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 ??? Index: prj.adb =================================================================== --- prj.adb (revision 160834) +++ prj.adb (working copy) @@ -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; ------------ Index: prj.ads =================================================================== --- prj.ads (revision 160834) +++ prj.ads (working copy) @@ -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;