From 0a3ec628c1db294a2135ea4fab8a71c121186cfb Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 20 Jan 2017 15:51:39 +0100 Subject: [PATCH] [multiple changes] 2017-01-20 Thomas Quinot * sem_warn.adb (Warn_On_Useless_Assignment): Adjust wording of warning message. 2017-01-20 Nicolas Roche * terminals.c: Ignore failures on setpgid and tcsetpgrp commands. 2017-01-20 Bob Duff * sem_eval.adb (Compile_Time_Compare): Disable the expr+literal (etc) optimizations when the type is modular. 2017-01-20 Yannick Moy * sem_ch6.adb (Move_Pragmas): move some pragmas, but copy the SPARK_Mode pragma instead of moving it. (Build_Subprogram_Declaration): Ensure that the generated spec and original body share the same SPARK_Pragma aspect/pragma. * sem_util.adb, sem_util.ads (Copy_SPARK_Mode_Aspect): New procedure to copy SPARK_Mode aspect. 2017-01-20 Bob Duff * sem_ch3.adb (Analyze_Declarations): Disable Resolve_Aspects even in ASIS mode. * sem_ch13.adb (Resolve_Name): Enable setting the entity to Empty even in ASIS mode. From-SVN: r244720 --- gcc/ada/ChangeLog | 30 ++++++++++++++++++++++++++++++ gcc/ada/sem_ch13.adb | 2 +- gcc/ada/sem_ch3.adb | 2 +- gcc/ada/sem_ch6.adb | 37 +++++++++++++++++++++---------------- gcc/ada/sem_eval.adb | 47 +++++++++++++++++++++++++++-------------------- gcc/ada/sem_util.adb | 18 ++++++++++++++++++ gcc/ada/sem_util.ads | 6 ++++++ gcc/ada/sem_warn.adb | 15 ++++++++++----- gcc/ada/terminals.c | 8 ++++---- 9 files changed, 118 insertions(+), 47 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c6c5f92..404b638 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,33 @@ +2017-01-20 Thomas Quinot + + * sem_warn.adb (Warn_On_Useless_Assignment): Adjust wording of warning + message. + +2017-01-20 Nicolas Roche + + * terminals.c: Ignore failures on setpgid and tcsetpgrp commands. + +2017-01-20 Bob Duff + + * sem_eval.adb (Compile_Time_Compare): Disable the expr+literal + (etc) optimizations when the type is modular. + +2017-01-20 Yannick Moy + + * sem_ch6.adb (Move_Pragmas): move some pragmas, + but copy the SPARK_Mode pragma instead of moving it. + (Build_Subprogram_Declaration): Ensure that the generated spec + and original body share the same SPARK_Pragma aspect/pragma. + * sem_util.adb, sem_util.ads (Copy_SPARK_Mode_Aspect): New + procedure to copy SPARK_Mode aspect. + +2017-01-20 Bob Duff + + * sem_ch3.adb (Analyze_Declarations): Disable Resolve_Aspects + even in ASIS mode. + * sem_ch13.adb (Resolve_Name): Enable setting the entity to + Empty even in ASIS mode. + 2017-01-20 Hristian Kirtchev * exp_ch9.adb: minor style fixes in comments. diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 5e8822a..bdb53b1 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -12731,7 +12731,7 @@ package body Sem_Ch13 is elsif Nkind (N) = N_Identifier and then Chars (N) /= Chars (E) then Find_Direct_Name (N); - if not ASIS_Mode then + if True or else not ASIS_Mode then -- ???? Set_Entity (N, Empty); end if; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 7ee02bc..096170b 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2570,7 +2570,7 @@ package body Sem_Ch3 is -- rejected. Pending notification we restrict this call to -- ASIS mode. - if ASIS_Mode then + if False and then ASIS_Mode then -- ???? Resolve_Aspects; end if; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 05631b3..5152ac1 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -2399,8 +2399,10 @@ package body Sem_Ch6 is -- of subprogram body From and insert them after node To. The pragmas -- in question are: -- Ghost - -- SPARK_Mode -- Volatile_Function + -- Also copy pragma SPARK_Mode if present in the declarative list + -- of subprogram body From and insert it after node To. This pragma + -- should not be moved, as it applies to the body too. ------------------ -- Move_Pragmas -- @@ -2425,14 +2427,17 @@ package body Sem_Ch6 is while Present (Decl) loop Next_Decl := Next (Decl); - if Nkind (Decl) = N_Pragma - and then Nam_In (Pragma_Name_Unmapped (Decl), - Name_Ghost, - Name_SPARK_Mode, - Name_Volatile_Function) - then - Remove (Decl); - Insert_After (To, Decl); + if Nkind (Decl) = N_Pragma then + if Pragma_Name_Unmapped (Decl) = Name_SPARK_Mode then + Insert_After (To, New_Copy_Tree (Decl)); + + elsif Nam_In (Pragma_Name_Unmapped (Decl), + Name_Ghost, + Name_Volatile_Function) + then + Remove (Decl); + Insert_After (To, Decl); + end if; end if; Decl := Next_Decl; @@ -2463,6 +2468,13 @@ package body Sem_Ch6 is Move_Aspects (N, To => Subp_Decl); Move_Pragmas (N, To => Subp_Decl); + -- Ensure that the generated corresponding spec and original body + -- share the same SPARK_Mode pragma or aspect. As a result, both have + -- the same SPARK_Mode attributes, and the global SPARK_Mode value is + -- correctly set for local subprograms. + + Copy_SPARK_Mode_Aspect (Subp_Decl, To => N); + Analyze (Subp_Decl); -- Propagate the attributes Rewritten_For_C and Corresponding_Proc to @@ -2515,13 +2527,6 @@ package body Sem_Ch6 is Body_Spec := Copy_Subprogram_Spec (Body_Spec); Set_Specification (N, Body_Spec); Body_Id := Analyze_Subprogram_Specification (Body_Spec); - - -- Ensure that the generated corresponding spec and original body - -- share the same SPARK_Mode attributes. - - Set_SPARK_Pragma (Body_Id, SPARK_Pragma (Spec_Id)); - Set_SPARK_Pragma_Inherited - (Body_Id, SPARK_Pragma_Inherited (Spec_Id)); end Build_Subprogram_Declaration; ---------------------------- diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 936c1c3..b421926 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -1142,7 +1142,7 @@ package body Sem_Eval is return Unknown; end if; - -- We do not attempt comparisons for packed arrays arrays represented as + -- We do not attempt comparisons for packed arrays represented as -- modular types, where the semantics of comparison is quite different. if Is_Packed_Array_Impl_Type (Ltyp) @@ -1329,28 +1329,35 @@ package body Sem_Eval is -- J .. J + 1. This code can conclude LT with a difference of 1, -- even if the range of J is not known. - declare - Lnode : Node_Id; - Loffs : Uint; - Rnode : Node_Id; - Roffs : Uint; + -- This would be wrong for modular types (e.g. X < X + 1 is False if + -- X is the largest number). - begin - Compare_Decompose (L, Lnode, Loffs); - Compare_Decompose (R, Rnode, Roffs); + if not Is_Modular_Integer_Type (Ltyp) + and then not Is_Modular_Integer_Type (Rtyp) + then + declare + Lnode : Node_Id; + Loffs : Uint; + Rnode : Node_Id; + Roffs : Uint; - if Is_Same_Value (Lnode, Rnode) then - if Loffs = Roffs then - return EQ; - elsif Loffs < Roffs then - Diff.all := Roffs - Loffs; - return LT; - else - Diff.all := Loffs - Roffs; - return GT; + begin + Compare_Decompose (L, Lnode, Loffs); + Compare_Decompose (R, Rnode, Roffs); + + if Is_Same_Value (Lnode, Rnode) then + if Loffs = Roffs then + return EQ; + elsif Loffs < Roffs then + Diff.all := Roffs - Loffs; + return LT; + else + Diff.all := Loffs - Roffs; + return GT; + end if; end if; - end if; - end; + end; + end if; -- Next, try range analysis and see if operand ranges are disjoint diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 0e1a0c0..73c8ce0 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -4999,6 +4999,24 @@ package body Sem_Util is return Plist; end Copy_Parameter_List; + ---------------------------- + -- Copy_SPARK_Mode_Aspect -- + ---------------------------- + + procedure Copy_SPARK_Mode_Aspect (From : Node_Id; To : Node_Id) is + pragma Assert (not Has_Aspects (To)); + Asp : Node_Id; + begin + if Has_Aspects (From) then + Asp := Find_Aspect (Defining_Entity (From), Aspect_SPARK_Mode); + + if Present (Asp) then + Set_Aspect_Specifications (To, New_List (New_Copy_Tree (Asp))); + Set_Has_Aspects (To, True); + end if; + end if; + end Copy_SPARK_Mode_Aspect; + -------------------------- -- Copy_Subprogram_Spec -- -------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index b437412..d084800 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -424,6 +424,12 @@ package Sem_Util is -- of inlining, and for private protected ops. Also used to create bodies -- for stubbed subprograms. + procedure Copy_SPARK_Mode_Aspect (From : Node_Id; To : Node_Id); + -- Copy the SPARK_Mode aspect if present in the aspect specifications + -- of node From to node To. On entry it is assumed that To does not have + -- aspect specifications. If From has no aspects, the routine has no + -- effect. + function Copy_Subprogram_Spec (Spec : Node_Id) return Node_Id; -- Replicate a function or a procedure specification denoted by Spec. The -- resulting tree is an exact duplicate of the original tree. New entities diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 5cd37f0..ad278e8 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -4323,7 +4323,12 @@ package body Sem_Warn is begin -- Don't give this for OUT and IN OUT formals, since -- clearly caller may reference the assigned value. Also - -- never give such warnings for internal variables. + -- never give such warnings for internal variables. In + -- either case, word the warning in a conditional way, + -- because in the case of a component of a controlled + -- type, the assigned value might be referenced in the + -- Finalize operation, so we can't make a definitive + -- statement that it's never referenced. if Ekind (Ent) = E_Variable and then not Is_Internal_Name (Chars (Ent)) @@ -4335,13 +4340,13 @@ package body Sem_Warn is N_Parameter_Association) then Error_Msg_NE - ("?m?& modified by call, but value never " - & "referenced", LA, Ent); + ("?m?& modified by call, but value might not " + & "be referenced", LA, Ent); else Error_Msg_NE -- CODEFIX - ("?m?useless assignment to&, value never " - & "referenced!", LA, Ent); + ("?m?possibly useless assignment to&, value " + & "might not be referenced!", LA, Ent); end if; end if; end; diff --git a/gcc/ada/terminals.c b/gcc/ada/terminals.c index 35185c7..35cd743 100644 --- a/gcc/ada/terminals.c +++ b/gcc/ada/terminals.c @@ -1425,10 +1425,10 @@ __gnat_setup_child_communication if (desc->slave_fd > 2) close (desc->slave_fd); /* adjust process group settings */ - if ((status = setpgid (pid, pid)) == -1) - return -1; - if ((status = tcsetpgrp (0, pid)) == -1) - return -1; + /* ignore failures of the following two commands as the context might not + * allow making those changes. */ + setpgid (pid, pid); + tcsetpgrp (0, pid); /* launch the program */ execvp (new_argv[0], new_argv); -- 2.7.4