From 319c61611e9a5a95ed7e05134f85f22113bc3b23 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 20 Oct 2015 13:59:22 +0200 Subject: [PATCH] [multiple changes] 2015-10-20 Yannick Moy * 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 * 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. From-SVN: r229053 --- gcc/ada/ChangeLog | 17 +++++++++++++++ gcc/ada/s-diflio.adb | 31 +++++++++++++++++++++++---- gcc/ada/s-diflio.ads | 8 ++++++- gcc/ada/sem_ch6.adb | 2 +- gcc/ada/sem_dim.adb | 50 ++++++++++++++++++++++++-------------------- gcc/ada/sem_warn.adb | 12 +++++++++++ 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 + + * 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 + + * 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 * 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;