From 3a2879357a1cd6e028c2426c1d20ce33c2892ce1 Mon Sep 17 00:00:00 2001 From: charlet Date: Thu, 4 Aug 2011 13:38:05 +0000 Subject: 2011-08-04 Bob Duff * sem_type.adb (Covers): If T2 is a subtype of a class-wide type, we need to compare with Class_Wide_Type (T2), in order to get at the original class-wide type node. * sem_type.ads (Covers): Improve the comment. * einfo.ads (Class_Wide_Type): Improve the comment. * exp_intr.adb (Expand_Unc_Deallocation): Remove unnecessary setting of the type of the Deref. 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. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@177385 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 23 ++++++++++++++ gcc/ada/einfo.ads | 4 +-- gcc/ada/exp_intr.adb | 1 - gcc/ada/gnat_rm.texi | 24 ++++++--------- gcc/ada/sem_prag.adb | 85 ++++++++++++++++++++++++++++++++++++++-------------- gcc/ada/sem_type.adb | 7 +++-- gcc/ada/sem_type.ads | 5 ++-- gcc/ada/sem_util.adb | 10 +++++++ gcc/ada/sem_util.ads | 7 +++-- 9 files changed, 119 insertions(+), 47 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 8484bcfac18..d2e9f0d85b3 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,26 @@ +2011-08-04 Bob Duff + + * sem_type.adb (Covers): If T2 is a subtype of a class-wide type, we + need to compare with Class_Wide_Type (T2), in order to get at the + original class-wide type node. + * sem_type.ads (Covers): Improve the comment. + * einfo.ads (Class_Wide_Type): Improve the comment. + * exp_intr.adb (Expand_Unc_Deallocation): Remove unnecessary setting of + the type of the Deref. + +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. + 2011-08-04 Yannick Moy * gnat_rm.texi: Document new pragma and aspect. diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 29baab0b43e..a4ca25d4890 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -567,8 +567,8 @@ package Einfo is -- Class_Wide_Type (Node9) -- Present in all type entities. For a tagged type or subtype, returns --- the corresponding implicitly declared class-wide type. Set to Empty --- for non-tagged types. +-- the corresponding implicitly declared class-wide type. For a +-- class-wide type, returns itself. Set to Empty for non-tagged types. -- Cloned_Subtype (Node16) -- Present in E_Record_Subtype and E_Class_Wide_Subtype entities. diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index 39fe8512041..778996bc023 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -1155,7 +1155,6 @@ package body Exp_Intr is D_Type : Entity_Id; begin - Set_Etype (Deref, Typ); Set_Parent (Deref, Free_Node); D_Subtyp := Make_Subtype_From_Expr (Deref, Desig_T); diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 70a678a00c4..8c22975c42c 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -5025,13 +5025,15 @@ pragma Test_Case ( @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 @@ -5053,14 +5055,6 @@ package Math_Functions is 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 diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 2a218612a26..3eb0bdb70f0 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -423,7 +423,13 @@ package body Sem_Prag is -- 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 @@ -454,12 +460,12 @@ package body Sem_Prag is 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 @@ package body Sem_Prag is 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 @@ package body Sem_Prag is -- 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 @@ package body Sem_Prag is 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 @@ package body Sem_Prag is 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; diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index cf48392c817..12f39138743 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -884,12 +884,13 @@ package body Sem_Type is return False; end; - -- In a dispatching call the actual may be class-wide, the formal - -- may be its specific type, or that of a descendent of it. + -- In a dispatching call, the formal is of some specific type, and the + -- actual is of the corresponding class-wide type, including a subtype + -- of the class-wide type. elsif Is_Class_Wide_Type (T2) and then - (Class_Wide_Type (T1) = T2 + (Class_Wide_Type (T1) = Class_Wide_Type (T2) or else Base_Type (Root_Type (T2)) = BT1) then return True; diff --git a/gcc/ada/sem_type.ads b/gcc/ada/sem_type.ads index 40e4c606df3..4d46a8e1fd1 100644 --- a/gcc/ada/sem_type.ads +++ b/gcc/ada/sem_type.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -164,7 +164,8 @@ package Sem_Type is function Covers (T1, T2 : Entity_Id) return Boolean; -- This is the basic type compatibility routine. T1 is the expected type, -- imposed by context, and T2 is the actual type. The processing reflects - -- both the definition of type coverage and the rules for operand matching. + -- both the definition of type coverage and the rules for operand matching; + -- that is, this does not exactly match the RM definition of "covers". function Disambiguate (N : Node_Id; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 5974f9cd57d..b7e3f21ff76 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -4331,6 +4331,16 @@ package body Sem_Util is 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 -- ------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index e880601bdf8..5078b3a23c7 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -485,7 +485,7 @@ package Sem_Util is -- 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 @@ package Sem_Util is -- 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 @@ package Sem_Util is -- 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 -- cgit v1.2.1