[multiple changes]
2011-11-21 Robert Dewar <dewar@adacore.com> * exp_imgv.adb (Expand_Width_Attribute): Handle case of Discard_Names. * sem_attr.adb (Eval_Attribute, case Width): Ditto. 2011-11-21 Thomas Quinot <quinot@adacore.com> * sinfo.ads: Minor reformatting. 2011-11-21 Yannick Moy <moy@adacore.com> * exp_util.adb: Minor reformatting. Update comments. From-SVN: r181581
This commit is contained in:
Arnaud Charlet
parent
8a06151a73
commit
5328a91df3
|
|
@ -1,3 +1,17 @@
|
|||
2011-11-21 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* exp_imgv.adb (Expand_Width_Attribute): Handle case of
|
||||
Discard_Names.
|
||||
* sem_attr.adb (Eval_Attribute, case Width): Ditto.
|
||||
|
||||
2011-11-21 Thomas Quinot <quinot@adacore.com>
|
||||
|
||||
* sinfo.ads: Minor reformatting.
|
||||
|
||||
2011-11-21 Yannick Moy <moy@adacore.com>
|
||||
|
||||
* exp_util.adb: Minor reformatting. Update comments.
|
||||
|
||||
2011-11-21 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* exp_prag.adb, exp_util.adb, sinfo.ads, sem_res.adb, s-stposu.adb,
|
||||
|
|
|
|||
|
|
@ -27,7 +27,6 @@ with Atree; use Atree;
|
|||
with Casing; use Casing;
|
||||
with Checks; use Checks;
|
||||
with Einfo; use Einfo;
|
||||
with Errout; use Errout;
|
||||
with Exp_Util; use Exp_Util;
|
||||
with Lib; use Lib;
|
||||
with Namet; use Namet;
|
||||
|
|
@ -246,7 +245,10 @@ package body Exp_Imgv is
|
|||
-- Snn (1 .. Pnn) then occurs as in the other cases. A special case is
|
||||
-- when pragma Discard_Names applies, in which case we replace expr by:
|
||||
|
||||
-- Missing ???
|
||||
-- (rt'pos (expr))'Img
|
||||
|
||||
-- So that the result is a space followed by the decimal value for the
|
||||
-- position of the enumeration value in the enumeration type.
|
||||
|
||||
procedure Expand_Image_Attribute (N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
|
|
@ -369,7 +371,7 @@ package body Exp_Imgv is
|
|||
or else No (Lit_Strings (Root_Type (Ptyp)))
|
||||
then
|
||||
-- When pragma Discard_Names applies to the first subtype, build
|
||||
-- (Pref'Pos)'Img.
|
||||
-- (Pref'Pos (Expr))'Img.
|
||||
|
||||
Rewrite (N,
|
||||
Make_Attribute_Reference (Loc,
|
||||
|
|
@ -1056,9 +1058,14 @@ package body Exp_Imgv is
|
|||
-- typ'Pos (Typ'Last))
|
||||
-- Wide_Character_Encoding_Method);
|
||||
|
||||
-- where typS and typI are the enumeration image strings and
|
||||
-- indexes table, as described in Build_Enumeration_Image_Tables.
|
||||
-- NN is 8/16/32 for depending on the element type for typI.
|
||||
-- where typS and typI are the enumeration image strings and indexes
|
||||
-- table, as described in Build_Enumeration_Image_Tables. NN is 8/16/32
|
||||
-- for depending on the element type for typI.
|
||||
|
||||
-- Finally if Discard_Names is in effect for an enumeration type, then
|
||||
-- a special conditional expression is built that yields the space needed
|
||||
-- for the decimal representation of the largest pos value in the subtype.
|
||||
-- See code below for details.
|
||||
|
||||
procedure Expand_Width_Attribute (N : Node_Id; Attr : Atype := Normal) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
|
|
@ -1126,7 +1133,6 @@ package body Exp_Imgv is
|
|||
-- Real types
|
||||
|
||||
elsif Is_Real_Type (Rtyp) then
|
||||
|
||||
Rewrite (N,
|
||||
Make_Conditional_Expression (Loc,
|
||||
Expressions => New_List (
|
||||
|
|
@ -1156,29 +1162,116 @@ package body Exp_Imgv is
|
|||
else
|
||||
pragma Assert (Is_Enumeration_Type (Rtyp));
|
||||
|
||||
-- Whenever pragma Discard_Names is in effect, it suppresses the
|
||||
-- generation of string literals for enumeration types. Since the
|
||||
-- literals are required to evaluate the 'Width of an enumeration
|
||||
-- type, emit an error.
|
||||
-- Whenever pragma Discard_Names is in effect, the value we need
|
||||
-- is the value needed to accomodate the largest integer pos value
|
||||
-- in the range of the subtype + 1 for the space at the start. We
|
||||
-- build:
|
||||
|
||||
-- ??? This is fine for configurable runtimes, but dubious in the
|
||||
-- general case. For now keep both error messages until this issue
|
||||
-- has been verified with the ARG.
|
||||
-- Tnn : constant Integer := Rtyp'Pos (Ptyp'Last)
|
||||
|
||||
-- and replace the expression by
|
||||
|
||||
-- (if Ptyp'Range_Length = 0 then 0
|
||||
-- else (if Tnn < 10 then 2
|
||||
-- else (if Tnn < 100 then 3
|
||||
-- ...
|
||||
-- else n)))...
|
||||
|
||||
-- where n is equal to Rtyp'Pos (Rtyp'Last) + 1
|
||||
|
||||
-- Note: The above processing is in accordance with the intent of
|
||||
-- the RM, which is that Width should be related to the impl-defined
|
||||
-- behavior of Image. It is not clear what this means if Image is
|
||||
-- not defined (as in the configurable run-time case for GNAT) and
|
||||
-- gives an error at compile time.
|
||||
|
||||
-- We choose in this case to just go ahead and implement Width the
|
||||
-- same way, returning what Image would have returned if it has been
|
||||
-- available in the configurable run-time library.
|
||||
|
||||
if Discard_Names (Rtyp) then
|
||||
Error_Msg_Name_1 := Attribute_Name (N);
|
||||
declare
|
||||
Tnn : constant Entity_Id :=
|
||||
Make_Defining_Identifier (Loc,
|
||||
Chars => New_Internal_Name ('T'));
|
||||
|
||||
if Configurable_Run_Time_Mode then
|
||||
Error_Msg_N ("attribute % not supported in configurable " &
|
||||
"run-time mode", N);
|
||||
else
|
||||
Error_Msg_N ("attribute % not supported when pragma " &
|
||||
"Discard_Names is in effect", N);
|
||||
end if;
|
||||
Cexpr : Node_Id;
|
||||
P : Int;
|
||||
M : Int;
|
||||
K : Int;
|
||||
|
||||
return;
|
||||
begin
|
||||
Insert_Action (N,
|
||||
Make_Object_Declaration (Loc,
|
||||
Defining_Identifier => Tnn,
|
||||
Constant_Present => True,
|
||||
Object_Definition =>
|
||||
New_Occurrence_Of (Standard_Integer, Loc),
|
||||
Expression =>
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Occurrence_Of (Rtyp, Loc),
|
||||
Attribute_Name => Name_Pos,
|
||||
Expressions => New_List (
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Occurrence_Of (Ptyp, Loc),
|
||||
Attribute_Name => Name_Last)))));
|
||||
|
||||
-- OK, now we need to build the conditional expression. First
|
||||
-- get the value of M, the largest possible value needed.
|
||||
|
||||
P := UI_To_Int
|
||||
(Enumeration_Pos (Entity (Type_High_Bound (Rtyp))));
|
||||
|
||||
K := 1;
|
||||
M := 1;
|
||||
while M < P loop
|
||||
M := M * 10;
|
||||
K := K + 1;
|
||||
end loop;
|
||||
|
||||
-- Build inner else
|
||||
|
||||
Cexpr := Make_Integer_Literal (Loc, K);
|
||||
|
||||
-- Wrap in inner if's until counted down to 2
|
||||
|
||||
while K > 2 loop
|
||||
M := M / 10;
|
||||
K := K - 1;
|
||||
|
||||
Cexpr :=
|
||||
Make_Conditional_Expression (Loc,
|
||||
Expressions => New_List (
|
||||
Make_Op_Lt (Loc,
|
||||
Left_Opnd => New_Occurrence_Of (Tnn, Loc),
|
||||
Right_Opnd => Make_Integer_Literal (Loc, M)),
|
||||
Make_Integer_Literal (Loc, K),
|
||||
Cexpr));
|
||||
end loop;
|
||||
|
||||
-- Add initial comparison for null range and we are done, so
|
||||
-- rewrite the attribute occurrence with this expression.
|
||||
|
||||
Rewrite (N,
|
||||
Convert_To (Typ,
|
||||
Make_Conditional_Expression (Loc,
|
||||
Expressions => New_List (
|
||||
Make_Op_Eq (Loc,
|
||||
Left_Opnd =>
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Occurrence_Of (Ptyp, Loc),
|
||||
Attribute_Name => Name_Range_Length),
|
||||
Right_Opnd => Make_Integer_Literal (Loc, 0)),
|
||||
Make_Integer_Literal (Loc, 0),
|
||||
Cexpr))));
|
||||
|
||||
Analyze_And_Resolve (N, Typ);
|
||||
return;
|
||||
end;
|
||||
end if;
|
||||
|
||||
-- Normal case, not Discard_Names
|
||||
|
||||
Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
|
||||
|
||||
case Attr is
|
||||
|
|
|
|||
|
|
@ -6420,23 +6420,29 @@ package body Exp_Util is
|
|||
-- Start of processing for Remove_Side_Effects
|
||||
|
||||
begin
|
||||
-- Handle cases in which there is nothing to do. In particular,
|
||||
-- side-effects are not removed in Alfa mode for formal verification.
|
||||
-- Instead, formal verification is performed only on those expressions
|
||||
-- provably side-effect free.
|
||||
-- We only need to do removal of side effects if we are generating
|
||||
-- actual code. That's because the whole issue of side effects is purely
|
||||
-- a run-time issue, and the removal is required only to get proper
|
||||
-- behavior at run-time.
|
||||
|
||||
-- Why? Is the Alfa mode test just an optimization? Most likely not,
|
||||
-- most likely it is functionally necessary, if so why ???
|
||||
-- In the Alfa case, we don't need to remove side effects because we
|
||||
-- only perform formal verification is performed only on expressions
|
||||
-- that are provably side-effect free. If we tried to remove side
|
||||
-- effects in the Alfa case, we would get into a mess since in the case
|
||||
-- of limited types in particular, removal of side effects involves the
|
||||
-- use of access types or references which are not permitted in Alfa
|
||||
-- mode.
|
||||
|
||||
if not Full_Expander_Active then
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- Cannot generate temporaries if the invocation to remove side effects
|
||||
-- was issued too early and the type of the expression is not resolved
|
||||
-- (this happens because routines Duplicate_Subexpr_XX implicitly invoke
|
||||
-- Remove_Side_Effects).
|
||||
|
||||
elsif No (Exp_Type)
|
||||
if No (Exp_Type)
|
||||
or else Ekind (Exp_Type) = E_Access_Attribute_Type
|
||||
then
|
||||
return;
|
||||
|
|
|
|||
|
|
@ -761,7 +761,7 @@ package Sinfo is
|
|||
-- if there is no corresponding spec, as in the case of a subprogram body
|
||||
-- that serves as its own spec.
|
||||
--
|
||||
-- In Ada2012, Corresponding_Spec is set on expression functions that
|
||||
-- In Ada 2012, Corresponding_Spec is set on expression functions that
|
||||
-- complete a subprogram declaration.
|
||||
|
||||
-- Corresponding_Stub (Node3-Sem)
|
||||
|
|
|
|||
Loading…
Reference in New Issue