[multiple changes]

2017-04-25  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch6.adb, sem_ch13.adb, sem_ch6.adb: Minor reformatting.

2017-04-25  Bob Duff  <duff@adacore.com>

	* 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

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  <kirtchev@adacore.com>
+
+	* exp_ch6.adb, sem_ch13.adb, sem_ch6.adb: Minor reformatting.
+
+2017-04-25  Bob Duff  <duff@adacore.com>
+
+	* 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  <schonberg@adacore.com>
 
 	* 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