From: Justin Squirek Date: Tue, 22 May 2018 13:17:58 +0000 (+0000) Subject: [Ada] No error on misplaced pragma Pure_Function X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=eaf51442d2d20864713492eb0355a9ec4abe0573;p=gcc.git [Ada] No error on misplaced pragma Pure_Function This patch fixes an issue whereby placement of the pragma/aspect Pure_Function was not verified to have been in the same declarative part as the function declaration incorrectly allowing it to appear after a function body or in a different region like a private section. 2018-05-22 Justin Squirek gcc/ada/ * sem_ch12.adb (In_Same_Declarative_Part): Moved to sem_util. (Freeze_Subprogram_Body, Install_Body): Modify calls to In_Same_Declarative_Part. * sem_prag.adb (Analyze_Pragma-Pragma_Pure_Function): Add check to verify pragma declaration is within the same declarative list with corresponding error message. * sem_util.adb, sem_util.ads (In_Same_Declarative_Part): Moved from sem_ch12.adb and generalized to be useful outside the scope of freezing. gcc/testsuite/ * gnat.dg/pure_function1.adb, gnat.dg/pure_function1.ads, gnat.dg/pure_function2.adb, gnat.dg/pure_function2.ads: New testcases. From-SVN: r260507 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 71e0aaf1f98..6341af867cc 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,15 @@ +2018-05-22 Justin Squirek + + * sem_ch12.adb (In_Same_Declarative_Part): Moved to sem_util. + (Freeze_Subprogram_Body, Install_Body): Modify calls to + In_Same_Declarative_Part. + * sem_prag.adb (Analyze_Pragma-Pragma_Pure_Function): Add check to + verify pragma declaration is within the same declarative list with + corresponding error message. + * sem_util.adb, sem_util.ads (In_Same_Declarative_Part): Moved from + sem_ch12.adb and generalized to be useful outside the scope of + freezing. + 2018-05-22 Hristian Kirtchev * sem_ch6.adb (Analyze_Subprogram_Declaration): Set the proper diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 8f7ba5cb01a..3d93619c685 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -657,17 +657,6 @@ package body Sem_Ch12 is -- not done for the instantiation of the bodies, which only require the -- instances of the generic parents to be in scope. - function In_Same_Declarative_Part - (F_Node : Node_Id; - Inst : Node_Id) return Boolean; - -- True if the instantiation Inst and the given freeze_node F_Node appear - -- within the same declarative part, ignoring subunits, but with no inter- - -- vening subprograms or concurrent units. Used to find the proper plave - -- for the freeze node of an instance, when the generic is declared in a - -- previous instance. If predicate is true, the freeze node of the instance - -- can be placed after the freeze node of the previous instance, Otherwise - -- it has to be placed at the end of the current declarative part. - function In_Main_Context (E : Entity_Id) return Boolean; -- Check whether an instantiation is in the context of the main unit. -- Used to determine whether its body should be elaborated to allow @@ -8664,7 +8653,8 @@ package body Sem_Ch12 is if Is_Generic_Instance (Par) and then Present (Freeze_Node (Par)) - and then In_Same_Declarative_Part (Freeze_Node (Par), Inst_Node) + and then In_Same_Declarative_Part + (Parent (Freeze_Node (Par)), Inst_Node) then -- The parent was a premature instantiation. Insert freeze node at -- the end the current declarative part. @@ -8711,11 +8701,11 @@ package body Sem_Ch12 is and then Present (Freeze_Node (Par)) and then Present (Enc_I) then - if In_Same_Declarative_Part (Freeze_Node (Par), Enc_I) + if In_Same_Declarative_Part (Parent (Freeze_Node (Par)), Enc_I) or else (Nkind (Enc_I) = N_Package_Body - and then - In_Same_Declarative_Part (Freeze_Node (Par), Parent (Enc_I))) + and then In_Same_Declarative_Part + (Parent (Freeze_Node (Par)), Parent (Enc_I))) then -- The enclosing package may contain several instances. Rather -- than computing the earliest point at which to insert its freeze @@ -8985,46 +8975,6 @@ package body Sem_Ch12 is (Current_Scope, Current_Scope, Assoc_Null); end Init_Env; - ------------------------------ - -- In_Same_Declarative_Part -- - ------------------------------ - - function In_Same_Declarative_Part - (F_Node : Node_Id; - Inst : Node_Id) return Boolean - is - Decls : constant Node_Id := Parent (F_Node); - Nod : Node_Id; - - begin - Nod := Parent (Inst); - while Present (Nod) loop - if Nod = Decls then - return True; - - elsif Nkind_In (Nod, N_Subprogram_Body, - N_Package_Body, - N_Package_Declaration, - N_Task_Body, - N_Protected_Body, - N_Block_Statement) - then - return False; - - elsif Nkind (Nod) = N_Subunit then - Nod := Corresponding_Stub (Nod); - - elsif Nkind (Nod) = N_Compilation_Unit then - return False; - - else - Nod := Parent (Nod); - end if; - end loop; - - return False; - end In_Same_Declarative_Part; - --------------------- -- In_Main_Context -- --------------------- @@ -9536,7 +9486,7 @@ package body Sem_Ch12 is -- Freeze instance of inner generic after instance of enclosing -- generic. - if In_Same_Declarative_Part (Freeze_Node (Par), N) then + if In_Same_Declarative_Part (Parent (Freeze_Node (Par)), N) then -- Handle the following case: @@ -9570,7 +9520,8 @@ package body Sem_Ch12 is -- instance of enclosing generic. elsif Nkind_In (Parent (N), N_Package_Body, N_Subprogram_Body) - and then In_Same_Declarative_Part (Freeze_Node (Par), Parent (N)) + and then In_Same_Declarative_Part + (Parent (Freeze_Node (Par)), Parent (N)) then declare Enclosing : Entity_Id; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index f235905229d..ed7441ae7f4 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -21043,6 +21043,8 @@ package body Sem_Prag is E : Entity_Id; E_Id : Node_Id; Effective : Boolean := False; + Orig_Def : Entity_Id; + Same_Decl : Boolean := False; begin GNAT_Pragma; @@ -21076,11 +21078,27 @@ package body Sem_Prag is ("pragma% requires a function name", Arg1); end if; - Set_Is_Pure (Def_Id); + -- When we have a generic function we must jump up a level + -- to the declaration of the wrapper package itself. - if not Has_Pragma_Pure_Function (Def_Id) then - Set_Has_Pragma_Pure_Function (Def_Id); - Effective := True; + Orig_Def := Def_Id; + + if Is_Generic_Instance (Def_Id) then + while Nkind (Orig_Def) /= N_Package_Declaration loop + Orig_Def := Parent (Orig_Def); + end loop; + end if; + + if In_Same_Declarative_Part (Parent (N), Orig_Def) then + + Same_Decl := True; + + Set_Is_Pure (Def_Id); + + if not Has_Pragma_Pure_Function (Def_Id) then + Set_Has_Pragma_Pure_Function (Def_Id); + Effective := True; + end if; end if; exit when From_Aspect_Specification (N); @@ -21094,6 +21112,10 @@ package body Sem_Prag is Error_Msg_NE ("pragma Pure_Function on& is redundant?r?", N, Entity (E_Id)); + elsif not Same_Decl then + Error_Pragma_Arg + ("pragma% argument must be in same declarative " + & "part", Arg1); end if; end if; end Pure_Function; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 52fd14f3619..8f0fcd38d8e 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -12024,6 +12024,50 @@ package body Sem_Util is and then Reverse_Storage_Order (Btyp); end In_Reverse_Storage_Order_Object; + ------------------------------ + -- In_Same_Declarative_Part -- + ------------------------------ + + function In_Same_Declarative_Part + (Context : Node_Id; + N : Node_Id) return Boolean + is + Cont : Node_Id := Context; + Nod : Node_Id; + + begin + if Nkind (Cont) = N_Compilation_Unit_Aux then + Cont := Parent (Cont); + end if; + + Nod := Parent (N); + while Present (Nod) loop + if Nod = Cont then + return True; + + elsif Nkind_In (Nod, N_Accept_Statement, + N_Block_Statement, + N_Compilation_Unit, + N_Entry_Body, + N_Package_Body, + N_Package_Declaration, + N_Protected_Body, + N_Subprogram_Body, + N_Task_Body) + then + return False; + + elsif Nkind (Nod) = N_Subunit then + Nod := Corresponding_Stub (Nod); + + else + Nod := Parent (Nod); + end if; + end loop; + + return False; + end In_Same_Declarative_Part; + -------------------------------------- -- In_Subprogram_Or_Concurrent_Unit -- -------------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 5007bb64487..7266ffab8d6 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1399,6 +1399,12 @@ package Sem_Util is -- Returns True if N denotes a component or subcomponent in a record or -- array that has Reverse_Storage_Order. + function In_Same_Declarative_Part + (Context : Node_Id; + N : Node_Id) return Boolean; + -- True if the node N appears within the same declarative part denoted by + -- the node Context. + function In_Subprogram_Or_Concurrent_Unit return Boolean; -- Determines if the current scope is within a subprogram compilation unit -- (inside a subprogram declaration, subprogram body, or generic subprogram diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 489941c617b..ca61568f5c5 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2018-05-22 Justin Squirek + + * gnat.dg/pure_function1.adb, gnat.dg/pure_function1.ads, + gnat.dg/pure_function2.adb, gnat.dg/pure_function2.ads: New testcases. + 2018-05-22 Richard Sandiford PR middle-end/85862 diff --git a/gcc/testsuite/gnat.dg/pure_function1.adb b/gcc/testsuite/gnat.dg/pure_function1.adb new file mode 100644 index 00000000000..9aab468dba8 --- /dev/null +++ b/gcc/testsuite/gnat.dg/pure_function1.adb @@ -0,0 +1,8 @@ +-- { dg-do compile } + +package body Pure_Function1 is + function F return Integer is (0); + pragma Pure_Function (F); -- { dg-error "pragma \"Pure_Function\" argument must be in same declarative part" } + pragma Pure_Function (F); -- { dg-error "pragma \"Pure_Function\" argument must be in same declarative part" } + pragma Pure_Function (F); -- { dg-error "pragma \"Pure_Function\" argument must be in same declarative part" } +end; diff --git a/gcc/testsuite/gnat.dg/pure_function1.ads b/gcc/testsuite/gnat.dg/pure_function1.ads new file mode 100644 index 00000000000..90b28fb1af9 --- /dev/null +++ b/gcc/testsuite/gnat.dg/pure_function1.ads @@ -0,0 +1,6 @@ +package Pure_Function1 is + function F return Integer; + pragma Pure_Function (F); + pragma Pure_Function (F); + pragma Pure_Function (F); +end; diff --git a/gcc/testsuite/gnat.dg/pure_function2.adb b/gcc/testsuite/gnat.dg/pure_function2.adb new file mode 100644 index 00000000000..28f98cd3dd5 --- /dev/null +++ b/gcc/testsuite/gnat.dg/pure_function2.adb @@ -0,0 +1,10 @@ +-- { dg-do compile } + +function Pure_Function2 (X : Integer) return Integer is +begin + return X; +end Pure_Function2; + +pragma Pure_Function (Pure_Function2); -- { dg-error "pragma \"Pure_Function\" argument must be in same declarative part" } +pragma Pure_Function (Pure_Function2); -- { dg-error "pragma \"Pure_Function\" argument must be in same declarative part" } +pragma Pure_Function (Pure_Function2); -- { dg-error "pragma \"Pure_Function\" argument must be in same declarative part" } diff --git a/gcc/testsuite/gnat.dg/pure_function2.ads b/gcc/testsuite/gnat.dg/pure_function2.ads new file mode 100644 index 00000000000..5cb714093bd --- /dev/null +++ b/gcc/testsuite/gnat.dg/pure_function2.ads @@ -0,0 +1,5 @@ +function Pure_Function2 (X : Integer) return Integer with Pure_Function; + +pragma Pure_Function (Pure_Function2); +pragma Pure_Function (Pure_Function2); +pragma Pure_Function (Pure_Function2);