From patchwork Thu Aug 4 13:38:15 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 108465 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 D9365B6F68 for ; Thu, 4 Aug 2011 23:38:34 +1000 (EST) Received: (qmail 6714 invoked by alias); 4 Aug 2011 13:38:32 -0000 Received: (qmail 6567 invoked by uid 22791); 4 Aug 2011 13:38:30 -0000 X-SWARE-Spam-Status: No, hits=-1.7 required=5.0 tests=AWL,BAYES_00,TW_TR X-Spam-Check-By: sourceware.org Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Thu, 04 Aug 2011 13:38:16 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 1FD7B2BB105; Thu, 4 Aug 2011 09:38:15 -0400 (EDT) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id aU-anstSlG5V; Thu, 4 Aug 2011 09:38:15 -0400 (EDT) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id 0C79F2BB041; Thu, 4 Aug 2011 09:38:15 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id 0C5B93FEE8; Thu, 4 Aug 2011 09:38:15 -0400 (EDT) Date: Thu, 4 Aug 2011 09:38:15 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Yannick Moy Subject: [Ada] Correct placement and checking of Test_Case pragma Message-ID: <20110804133815.GA10374@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) 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 Follow-up of changes for Test_Case pragma. Pragma is not allowed inside subprogram body, only after separate declaration. No two test cases with same name allowed on same entity. Correct error in checking procedure. Tested on x86_64-pc-linux-gnu, committed on trunk 2011-08-04 Yannick Moy * gnat_rm.texi: Document that Test_Case pragma can only appear on separate declarations. * sem_prag.adb (procedure Check_Identifier_Is_One_Of): new procedure to check identifier of pragma argument. (Chain_TC): check that no other test case associated to the same entity share the same name. (Check_Test_Case): disallow test case inside subprogram body (Analyze_Pragma): correct call to check identifier and not argument * sem_util.adb, sem_util.ads (Get_Name_From_Test_Case_Pragma): new function gets name from test case pragma. Index: gnat_rm.texi =================================================================== --- gnat_rm.texi (revision 177384) +++ gnat_rm.texi (working copy) @@ -5025,14 +5025,16 @@ @end smallexample @noindent -The @code{Test_Case} pragma applies to the same entities as pragmas -@code{Precondition} and @code{Postcondition}. In particular, the -placement and visibility rules are identical to those described for pre- -and postconditions. But the presence of pragma @code{Test_Case} does not -lead to any modification of the code generated by the compiler. Rather, -its purpose is to document finer-grain specifications for use by testing -and verification tools. +The @code{Test_Case} pragma allows defining fine-grain specifications +for use by testing and verification tools. The compiler only checks its +validity but the presence of pragma @code{Test_Case} does not lead to +any modification of the code generated by the compiler. +@code{Test_Case} pragmas may only appear immediately following the +(separate) declaration of a subprogram. Only other pragmas may intervene +(that is appear between the subprogram declaration and its +postconditions). + The compiler checks that boolean expression given in @code{Requires} and @code{Ensures} are valid, where the rules for @code{Requires} are the same as the rule for an expression in @code{Precondition} and the rules @@ -5053,14 +5055,6 @@ end Math_Functions; @end smallexample -@noindent -@code{Test_Case} pragmas may appear either immediately following the -(separate) declaration of a subprogram, or at the start of the -declarations of a subprogram body. Only other pragmas may intervene -(that is appear between the subprogram declaration and its test cases, -or appear before the test case in the declaration sequence in a -subprogram body). - @node Pragma Thread_Local_Storage @unnumberedsec Pragma Thread_Local_Storage @findex Thread_Local_Storage Index: sem_prag.adb =================================================================== --- sem_prag.adb (revision 177384) +++ sem_prag.adb (working copy) @@ -423,8 +423,14 @@ -- Checks that the given argument has an identifier, and if so, requires -- it to match the given identifier name. If there is no identifier, or -- a non-matching identifier, then an error message is given and - -- Error_Pragmas raised. + -- Pragma_Exit is raised. + procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id); + -- Checks that the given argument has an identifier, and if so, requires + -- it to match one of the given identifier names. If there is no + -- identifier, or a non-matching identifier, then an error message is + -- given and Pragma_Exit is raised. + procedure Check_In_Main_Program; -- Common checks for pragmas that appear within a main program -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU). @@ -454,12 +460,12 @@ procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id); -- Checks if the given argument has an identifier, and if so, requires -- it to match the given identifier name. If there is a non-matching - -- identifier, then an error message is given and Error_Pragmas raised. + -- identifier, then an error message is given and Pragma_Exit is raised. procedure Check_Optional_Identifier (Arg : Node_Id; Id : String); -- Checks if the given argument has an identifier, and if so, requires -- it to match the given identifier name. If there is a non-matching - -- identifier, then an error message is given and Error_Pragmas raised. + -- identifier, then an error message is given and Pragma_Exit is raised. -- In this version of the procedure, the identifier name is given as -- a string with lower case letters. @@ -1432,6 +1438,30 @@ end if; end Check_Identifier; + -------------------------------- + -- Check_Identifier_Is_One_Of -- + -------------------------------- + + procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is + begin + if Present (Arg) + and then Nkind (Arg) = N_Pragma_Argument_Association + then + if Chars (Arg) = No_Name then + Error_Msg_Name_1 := Pname; + Error_Msg_N ("pragma% argument expects an identifier", Arg); + raise Pragma_Exit; + + elsif Chars (Arg) /= N1 + and then Chars (Arg) /= N2 + then + Error_Msg_Name_1 := Pname; + Error_Msg_N ("invalid identifier for pragma% argument", Arg); + raise Pragma_Exit; + end if; + end if; + end Check_Identifier_Is_One_Of; + --------------------------- -- Check_In_Main_Program -- --------------------------- @@ -1989,6 +2019,33 @@ -- in this analysis, allowing forward references. The analysis -- happens at the end of Analyze_Declarations. + -- There should not be another test case with the same name + -- associated to this subprogram. + + declare + Name : constant String_Id := Get_Name_From_Test_Case_Pragma (N); + TC : Node_Id; + + begin + TC := Spec_TC_List (Contract (S)); + while Present (TC) loop + + if String_Equal + (Name, Get_Name_From_Test_Case_Pragma (TC)) + then + Error_Msg_Sloc := Sloc (TC); + + if From_Aspect_Specification (N) then + Error_Pragma ("name for aspect% is already used#"); + else + Error_Pragma ("name for pragma% is already used#"); + end if; + end if; + + TC := Next_Pragma (TC); + end loop; + end; + -- Chain spec TC pragma to list for subprogram Set_Next_Pragma (N, Spec_TC_List (Contract (S))); @@ -2039,25 +2096,9 @@ end loop; -- If we fall through loop, pragma is at start of list, so see if it - -- is at the start of declarations of a subprogram body. + -- is in the pragmas after a library level subprogram. - if Nkind (Parent (N)) = N_Subprogram_Body - and then List_Containing (N) = Declarations (Parent (N)) - then - if Operating_Mode /= Generate_Code - or else Inside_A_Generic - then - -- Analyze pragma expressions for correctness and for ASIS use - - Preanalyze_TC_Args (Get_Requires_From_Test_Case_Pragma (N), - Get_Ensures_From_Test_Case_Pragma (N)); - end if; - - return; - - -- See if it is in the pragmas after a library level subprogram - - elsif Nkind (Parent (N)) = N_Compilation_Unit_Aux then + if Nkind (Parent (N)) = N_Compilation_Unit_Aux then Chain_TC (Unit (Parent (Parent (N)))); return; end if; @@ -13246,7 +13287,7 @@ Check_Identifier (Arg3, Name_Requires); Check_Identifier (Arg4, Name_Ensures); else - Check_Arg_Is_One_Of (Arg3, Name_Requires, Name_Ensures); + Check_Identifier_Is_One_Of (Arg3, Name_Requires, Name_Ensures); end if; Check_Test_Case; Index: sem_util.adb =================================================================== --- sem_util.adb (revision 177384) +++ sem_util.adb (working copy) @@ -4331,6 +4331,16 @@ return Entity_Id (Get_Name_Table_Info (Id)); end Get_Name_Entity_Id; + ------------------------------------ + -- Get_Name_From_Test_Case_Pragma -- + ------------------------------------ + + function Get_Name_From_Test_Case_Pragma (N : Node_Id) return String_Id is + begin + return + Strval (Get_Pragma_Arg (First (Pragma_Argument_Associations (N)))); + end Get_Name_From_Test_Case_Pragma; + ------------------- -- Get_Pragma_Id -- ------------------- Index: sem_util.ads =================================================================== --- sem_util.ads (revision 177384) +++ sem_util.ads (working copy) @@ -485,7 +485,7 @@ -- Otherwise return Empty. Expression N should have been resolved already. function Get_Ensures_From_Test_Case_Pragma (N : Node_Id) return Node_Id; - -- Return the Ensures components of Test_Case pragma N, or Empty otherwise + -- Return the Ensures component of Test_Case pragma N, or Empty otherwise function Get_Generic_Entity (N : Node_Id) return Entity_Id; -- Returns the true generic entity in an instantiation. If the name in the @@ -518,6 +518,9 @@ -- is the innermost visible entity with the given name. See the body of -- Sem_Ch8 for further details on handling of entity visibility. + function Get_Name_From_Test_Case_Pragma (N : Node_Id) return String_Id; + -- Return the Name component of Test_Case pragma N + function Get_Pragma_Id (N : Node_Id) return Pragma_Id; pragma Inline (Get_Pragma_Id); -- Obtains the Pragma_Id from the Chars field of Pragma_Identifier (N) @@ -534,7 +537,7 @@ -- with any other kind of entity. function Get_Requires_From_Test_Case_Pragma (N : Node_Id) return Node_Id; - -- Return the Requires components of Test_Case pragma N, or Empty otherwise + -- Return the Requires component of Test_Case pragma N, or Empty otherwise function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id; -- Nod is either a procedure call statement, or a function call, or an