2015-10-20 Yannick Moy <moy@adacore.com>

	* sem_warn.adb (Is_OK_Fully_Initialized): Consider types with DIC as
	fully default initialized.
	* sem_ch6.adb: minor style fix in comment

2015-10-20  Ed Schonberg  <schonberg@adacore.com>

	* s-diflio.ads, s-diflio.adb (Image): New function for dimensioned
	quantities, to produce a string that includes the dimension
	synbol for the quantity, or the vector of dimensions in standard
	notation.
	* sem_dim.adb (Expand_Put_Call_With_Symbol): Process new function
	Image, to include dimension information in the generated string,
	identical to the string produced by the Put procedure on a string
	for a dimensioned quantity.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@229053 138bc75d-0d04-0410-961f-82ee72b054a4

6 files changed, 91 insertions, 29 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 0599e3222f9..54ec2ef2dc2 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,20 @@
+2015-10-20  Yannick Moy  <moy@adacore.com>
+
+	* sem_warn.adb (Is_OK_Fully_Initialized): Consider types with DIC as
+	fully default initialized.
+	* sem_ch6.adb: minor style fix in comment
+
+2015-10-20  Ed Schonberg  <schonberg@adacore.com>
+
+	* s-diflio.ads, s-diflio.adb (Image): New function for dimensioned
+	quantities, to produce a string that includes the dimension
+	synbol for the quantity, or the vector of dimensions in standard
+	notation.
+	* sem_dim.adb (Expand_Put_Call_With_Symbol): Process new function
+	Image, to include dimension information in the generated string,
+	identical to the string produced by the Put procedure on a string
+	for a dimensioned quantity.
+
 2015-10-20  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* exp_ch7.adb (Process_Declarations): A loop
diff --git a/gcc/ada/s-diflio.adb b/gcc/ada/s-diflio.adb
index 527d7bbbaf8..5c553a0912e 100644
--- a/gcc/ada/s-diflio.adb
+++ b/gcc/ada/s-diflio.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2011-2012, Free Software Foundation, Inc.         --
+--          Copyright (C) 2011-2015, 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- --
@@ -69,9 +69,11 @@ package body System.Dim.Float_IO is
       Exp    : Field  := Default_Exp;
       Symbol : String := "")
    is
+      Ptr : constant Natural := Symbol'Length;
+
    begin
-      Num_Dim_Float_IO.Put (To, Item, Aft, Exp);
-      To := To & Symbol;
+      Num_Dim_Float_IO.Put (To (To'First .. To'Last - Ptr), Item, Aft, Exp);
+      To (To'Last - Ptr + 1 .. To'Last) := Symbol;
    end Put;
 
    ----------------
@@ -104,6 +106,27 @@ package body System.Dim.Float_IO is
       Symbol : String := "")
    is
    begin
-      To := Symbol;
+      To (1 .. Symbol'Length) := Symbol;
    end Put_Dim_Of;
+
+   -----------
+   -- Image --
+   -----------
+
+   function Image
+     (Item : Num_Dim_Float;
+      Aft    : Field  := Default_Aft;
+      Exp    : Field  := Default_Exp;
+      Symbol : String := "") return String
+   is
+      Buffer : String (1 .. 50);
+
+   begin
+      Put (Buffer, Item, Aft, Exp);
+      for I in Buffer'Range loop
+         if Buffer (I) /= ' ' then
+            return Buffer (I .. Buffer'Last) & Symbol;
+         end if;
+      end loop;
+   end Image;
 end System.Dim.Float_IO;
diff --git a/gcc/ada/s-diflio.ads b/gcc/ada/s-diflio.ads
index cd3410b4a97..df550929ea3 100644
--- a/gcc/ada/s-diflio.ads
+++ b/gcc/ada/s-diflio.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2011-2013, Free Software Foundation, Inc.         --
+--          Copyright (C) 2011-2015, 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- --
@@ -175,4 +175,10 @@ package System.Dim.Float_IO is
    pragma Inline (Put);
    pragma Inline (Put_Dim_Of);
 
+   function Image
+     (Item : Num_Dim_Float;
+      Aft    : Field  := Default_Aft;
+      Exp    : Field  := Default_Exp;
+      Symbol : String := "") return String;
+
 end System.Dim.Float_IO;
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 0243700eb83..927a4762a89 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -4388,7 +4388,7 @@ package body Sem_Ch6 is
 
       --  Flag Is_Inlined_Always is True by default, and reversed to False for
       --  those subprograms which could be inlined in GNATprove mode (because
-      --  Body_To_Inline is non-Empty) but cannot be inlined.
+      --  Body_To_Inline is non-Empty) but should not be inlined.
 
       if GNATprove_Mode then
          Set_Is_Inlined_Always (Designator);
diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb
index e9bafa40f8a..f9448343e28 100644
--- a/gcc/ada/sem_dim.adb
+++ b/gcc/ada/sem_dim.adb
@@ -2658,11 +2658,12 @@ package body Sem_Dim is
    -- Expand_Put_Call_With_Symbol --
    ---------------------------------
 
-   --  For procedure Put (resp. Put_Dim_Of) defined in System.Dim.Float_IO
-   --  (System.Dim.Integer_IO), the default string parameter must be rewritten
-   --  to include the unit symbols (resp. dimension symbols) in the output
-   --  of a dimensioned object. Note that if a value is already supplied for
-   --  parameter Symbol, this routine doesn't do anything.
+   --  For procedure Put (resp. Put_Dim_Of) and function Image, defined in
+   --  System.Dim.Float_IO or System.Dim.Integer_IO, the default string
+   --  parameter is rewritten to include the unit symbol (or the dimension
+   --  symbols if not a defined quantity) in the output of a dimensioned
+   --  object.  If a value is already supplied by the user for the parameter
+   --  Symbol, it is used as is.
 
    --  Case 1. Item is dimensionless
 
@@ -2708,6 +2709,9 @@ package body Sem_Dim is
    --      $5.0 m**3.cd**(-1)
    --      $[l**3.J**(-1)]
 
+   --      The function Image returns the string identical to that produced by
+   --      a call to Put whose first parameter is a string.
+
    procedure Expand_Put_Call_With_Symbol (N : Node_Id) is
       Actuals        : constant List_Id := Parameter_Associations (N);
       Loc            : constant Source_Ptr := Sloc (N);
@@ -2773,22 +2777,12 @@ package body Sem_Dim is
             if Present (Actual_Str) then
 
                --  Return True if the actual comes from source or if the string
-               --  of symbols doesn't have the default value (i.e. it is "").
+               --  of symbols doesn't have the default value (i.e. it is ""),
+               --  in which case it is used as suffix of the generated string.
 
                if Comes_From_Source (Actual)
                  or else String_Length (Strval (Actual_Str)) /= 0
                then
-                  --  Complain only if the actual comes from source or if it
-                  --  hasn't been fully analyzed yet.
-
-                  if Comes_From_Source (Actual)
-                    or else not Analyzed (Actual)
-                  then
-                     Error_Msg_N ("Symbol parameter should not be provided",
-                                  Actual);
-                     Error_Msg_N ("\reserved for compiler use only", Actual);
-                  end if;
-
                   return True;
 
                else
@@ -2841,7 +2835,9 @@ package body Sem_Dim is
                   Is_Put_Dim_Of := True;
                   return True;
 
-               elsif Chars (Ent) = Name_Put then
+               elsif Chars (Ent) = Name_Put
+                 or else Chars (Ent) = Name_Image
+               then
                   return True;
                end if;
             end if;
@@ -2976,12 +2972,20 @@ package body Sem_Dim is
 
             --  Rewrite and analyze the procedure call
 
-            Rewrite (N,
-              Make_Procedure_Call_Statement (Loc,
-                Name =>                   New_Copy (Name_Call),
-                Parameter_Associations => New_Actuals));
+            if Chars (Name_Call) = Name_Image then
+               Rewrite (N,
+                 Make_Function_Call (Loc,
+                   Name =>                   New_Copy (Name_Call),
+                   Parameter_Associations => New_Actuals));
+               Analyze_And_Resolve (N);
+            else
+               Rewrite (N,
+                 Make_Procedure_Call_Statement (Loc,
+                   Name =>                   New_Copy (Name_Call),
+                   Parameter_Associations => New_Actuals));
+               Analyze (N);
+            end if;
 
-            Analyze (N);
          end if;
       end if;
    end Expand_Put_Call_With_Symbol;
diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb
index 9140a0899f6..3af69c9fbd0 100644
--- a/gcc/ada/sem_warn.adb
+++ b/gcc/ada/sem_warn.adb
@@ -1697,6 +1697,18 @@ package body Sem_Warn is
       begin
          if Is_Access_Type (Typ) and then Is_Dereferenced (N) then
             return False;
+
+         --  If a type has Default_Initial_Condition set, or it inherits it,
+         --  DIC might be specified with a boolean value, meaning that the type
+         --  is considered to be fully default initialized (SPARK RM 3.1 and
+         --  SPARK RM 7.3.3). To avoid generating spurious warnings in this
+         --  case, consider all types with DIC as fully initialized.
+
+         elsif Has_Default_Init_Cond (Typ)
+           or else Has_Inherited_Default_Init_Cond (Typ)
+         then
+            return True;
+
          else
             return Is_Fully_Initialized_Type (Typ);
          end if;