From a267d8ccb7df8b87c9f8680a32ea4530c86a600e Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 25 Apr 2017 14:56:34 +0200 Subject: [PATCH] [multiple changes] 2017-04-25 Hristian Kirtchev * exp_ch6.adb, sem_ch13.adb, sem_ch6.adb: Minor reformatting. 2017-04-25 Bob Duff * sem_res.adb (Resolve_Actuals): Under -gnatd.q, reset Is_True_Constant for an array variable that is passed to a foreign function as an 'in' parameter. * debug.adb: Document -gnatd.q. From-SVN: r247218 --- gcc/ada/ChangeLog | 11 +++++++++++ gcc/ada/debug.adb | 13 ++++++++++--- gcc/ada/exp_ch6.adb | 8 ++++---- gcc/ada/sem_ch13.adb | 21 ++++++++------------- gcc/ada/sem_ch6.adb | 8 ++++---- gcc/ada/sem_res.adb | 15 +++++++++++++++ 6 files changed, 52 insertions(+), 24 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index da7cb6f..28499f6 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,14 @@ +2017-04-25 Hristian Kirtchev + + * exp_ch6.adb, sem_ch13.adb, sem_ch6.adb: Minor reformatting. + +2017-04-25 Bob Duff + + * sem_res.adb (Resolve_Actuals): Under -gnatd.q, reset + Is_True_Constant for an array variable that is passed to a + foreign function as an 'in' parameter. + * debug.adb: Document -gnatd.q. + 2017-04-25 Ed Schonberg * sem_ch6.adb (Analyze_Expression_Function): If expression function diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index b404ac8..d855fa8 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -107,7 +107,7 @@ package body Debug is -- d.n Print source file names -- d.o Conservative elaboration order for indirect calls -- d.p Use original Ada 95 semantics for Bit_Order (disable AI95-0133) - -- d.q + -- d.q Suppress optimizations on imported 'in' -- d.r Enable OK_To_Reorder_Components in non-variant records -- d.s -- d.t Disable static allocation of library level dispatch tables @@ -562,6 +562,13 @@ package body Debug is -- interpretation of component clauses crossing byte boundaries when -- using the non-default bit order (i.e. ignore AI95-0133). + -- d.q If an array variable or constant is not modified in Ada code, and + -- is passed to an 'in' parameter of a foreign-convention subprogram, + -- and that subprogram modifies the array, the Ada compiler normally + -- assumes that the array is not modified. This option suppresses such + -- optimizations. This option should not be used; the correct solution + -- is to declare the parameter 'in out'. + -- d.r Forces the flag OK_To_Reorder_Components to be set in all record -- base types that have no discriminants. @@ -826,8 +833,8 @@ package body Debug is -- prefer specs with no bodies to specs with bodies, and between two -- specs with bodies, prefers the one whose body is closer to being -- able to be elaborated. This is a clear improvement, but we provide - -- this debug flag in case of regressions. Note: -do is even older than - -- -dp. + -- this debug flag in case of regressions. Note: -gnatdo is even older + -- than -gnatdp. -- dp Use old elaboration order preference. The new preference rules -- elaborate all units within a strongly connected component together, diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 24de185..d8443ac 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -409,13 +409,13 @@ package body Exp_Ch6 is Desig_Typ := Directly_Designated_Type (Ptr_Typ); -- Check for a library-level access type whose designated type has - -- supressed finalization. Such an access types lack a master. - -- Pass a null actual to the callee in order to signal a missing - -- master. + -- suppressed finalization or the access type is subject to pragma + -- No_Heap_Finalization. Such an access type lacks a master. Pass + -- a null actual to callee in order to signal a missing master. if Is_Library_Level_Entity (Ptr_Typ) and then (Finalize_Storage_Only (Desig_Typ) - or else No_Heap_Finalization (Ptr_Typ)) + or else No_Heap_Finalization (Ptr_Typ)) then Actual := Make_Null (Loc); diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 16a586b..add5680 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -4371,18 +4371,13 @@ package body Sem_Ch13 is -- Note that analysis will have added the interpretation -- that corresponds to the dereference. We only check the - -- subprogram itself. + -- subprogram itself. Ignore homonyms that may come from + -- derived types in the context. - if Is_Overloadable (It.Nam) then - - -- Ignore homonyms that may come from derived types - -- in the context. - - if not Comes_From_Source (It.Nam) then - null; - else - Check_One_Function (It.Nam); - end if; + if Is_Overloadable (It.Nam) + and then Comes_From_Source (It.Nam) + then + Check_One_Function (It.Nam); end if; Get_Next_Interp (I, It); @@ -4392,8 +4387,8 @@ package body Sem_Ch13 is if not Indexing_Found and then not Error_Posted (N) then Error_Msg_NE - ("aspect Indexing requires a local function that " - & "applies to type&", Expr, Ent); + ("aspect Indexing requires a local function that applies to " + & "type&", Expr, Ent); end if; end Check_Indexing_Functions; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index e8f29df..e52d285 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -3091,15 +3091,15 @@ package body Sem_Ch6 is -- Check that the enclosing record type can be frozen. -- This provides a better error message than generating - -- primitives whose compilation fails much later. - -- Refine the error message if possible. + -- primitives whose compilation fails much later. Refine + -- the error message if possible. Check_Fully_Declared (Rec, Node); if Error_Posted (Node) then if Has_Private_Component (Rec) then - Error_Msg_NE ("\type& has private component", - Node, Rec); + Error_Msg_NE + ("\type& has private component", Node, Rec); end if; else diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 2a8010d..4afba9e 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -4211,6 +4211,21 @@ package body Sem_Res is end if; end if; + -- In -gnatd.q mode, forget that a given array is constant when + -- it is passed as an IN parameter to a foreign-convention + -- subprogram. This is in case the subprogram evilly modifies the + -- object. Of course, correct code would use IN OUT. + + if Debug_Flag_Dot_Q + and then Ekind (F) = E_In_Parameter + and then Has_Foreign_Convention (Nam) + and then Is_Array_Type (F_Typ) + and then Nkind (A) in N_Has_Entity + and then Present (Entity (A)) + then + Set_Is_True_Constant (Entity (A), False); + end if; + -- Case of OUT or IN OUT parameter if Ekind (F) /= E_In_Parameter then -- 2.7.4