[multiple changes]
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. From-SVN: r229053
This commit is contained in:
parent
d29f68cf55
commit
319c61611e
|
@ -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
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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);
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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;
|
||||
|
|
Loading…
Reference in New Issue