OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

s-valint.adb: Fix typo in last checkin. 

2015-01-06  Robert Dewar  <dewar@adacore.com>

	* s-valint.adb: Fix typo in last checkin.
	* s-valuns.adb (Value_Unsigned): More efficient fix for
	Positive'Last case.
	* sem_attr.adb (Analyze_Attribute): Minor reformatting
	(Eval_Attribute): Static ervaluation of 'Img for enumeration types.

From-SVN: r219243
This commit is contained in:
Robert Dewar 2015-01-06 09:55:03 +00:00 committed by Arnaud Charlet
parent 8d1359c773
commit 21db8699c3
4 changed files with 66 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
gcc/ada/ChangeLog
View File

@ -1,3 +1,11 @@
2015-01-06 Robert Dewar <dewar@adacore.com>
* s-valint.adb: Fix typo in last checkin.
* s-valuns.adb (Value_Unsigned): More efficient fix for
Positive'Last case.
* sem_attr.adb (Analyze_Attribute): Minor reformatting
(Eval_Attribute): Static ervaluation of 'Img for enumeration types.
2015-01-06 Robert Dewar <dewar@adacore.com>
* s-valint.adb, s-valuns.adb (Value_Integer): Deal with case where

2
gcc/ada/s-valint.adb
View File

@ -108,7 +108,7 @@ package body System.Val_Int is
V : Integer;
P : aliased Integer := Str'First;
begin
V := Scan_Integer (Str, P'Access, Str'Length);
V := Scan_Integer (Str, P'Access, Str'Last);
Scan_Trailing_Blanks (Str, P);
return V;
end;

33
gcc/ada/s-valuns.adb
View File

@ -289,17 +289,30 @@ package body System.Val_Uns is
--------------------
function Value_Unsigned (Str : String) return Unsigned is
subtype NT is String (1 .. Str'Length);
-- We use this subtype to convert Str for the calls below to deal with
-- the obscure case where Str'Last is Positive'Last. Without these
-- conversions, such a case would raise Constraint_Error.
V : Unsigned;
P : aliased Integer := 1;
begin
V := Scan_Unsigned (NT (Str), P'Access, Str'Length);
Scan_Trailing_Blanks (NT (Str), P);
return V;
-- We have to special case Str'Last = Positive'Last because the normal
-- circuit ends up setting P to Str'Last + 1 which is out of bounds. We
-- deal with this by converting to a subtype which fixes the bounds.
if Str'Last = Positive'Last then
declare
subtype NT is String (1 .. Str'Length);
begin
return Value_Unsigned (NT (Str));
end;
-- Normal case where Str'Last < Positive'Last
else
declare
V : Unsigned;
P : aliased Integer := Str'First;
begin
V := Scan_Unsigned (Str, P'Access, Str'Last);
Scan_Trailing_Blanks (Str, P);
return V;
end;
end if;
end Value_Unsigned;
end System.Val_Uns;

96
gcc/ada/sem_attr.adb
View File

@ -2454,8 +2454,8 @@ package body Sem_Attr is
and then Attr_Id /= Attribute_Unrestricted_Access
then
Error_Msg_N
("in a constraint the current instance can only"
& " be used with an access attribute", N);
("in a constraint the current instance can only "
& "be used with an access attribute", N);
end if;
end if;
end;
@ -3378,31 +3378,6 @@ package body Sem_Attr is
Set_Etype (N, Standard_Boolean);
----------------
-- Enum_Image --
----------------
when Attribute_Enum_Image => Enum_Image :
begin
Check_SPARK_05_Restriction_On_Attribute;
Check_Scalar_Type;
Set_Etype (N, Standard_String);
if not Is_Enumeration_Type (P_Type) then
Error_Msg_Name_1 := Aname;
Error_Msg_N
("% attribute only allowed for enumerated types", N);
end if;
Check_E1;
Resolve (E1, P_Base_Type);
if not Is_OK_Static_Expression (E1) then
Error_Msg_Name_1 := Aname;
Error_Msg_N ("% attribute requires static argument", E1);
end if;
end Enum_Image;
--------------
-- Enum_Rep --
--------------
@ -7231,6 +7206,34 @@ package body Sem_Attr is
return;
end if;
-- Attribute 'Img applied to a static enumeration value is static, and
-- we will do the folding right here (things get confused if we let this
-- case go through the normal circuitry).
if Attribute_Name (N) = Name_Img
and then Is_Entity_Name (P)
and then Is_Enumeration_Type (Etype (Entity (P)))
and then Is_OK_Static_Expression (P)
then
declare
Lit : constant Entity_Id := Expr_Value_E (P);
Str : String_Id;
begin
Start_String;
Get_Unqualified_Decoded_Name_String (Chars (Lit));
Set_Casing (All_Upper_Case);
Store_String_Chars (Name_Buffer (1 .. Name_Len));
Str := End_String;
Rewrite (N, Make_String_Literal (Loc, Strval => Str));
Analyze_And_Resolve (N, Standard_String);
Set_Is_Static_Expression (N, True);
end;
return;
end if;
-- Special processing for cases where the prefix is an object. For
-- this purpose, a string literal counts as an object (attributes
-- of string literals can only appear in generated code).
@ -7394,9 +7397,7 @@ package body Sem_Attr is
-- Second foldable possibility is an array object (RM 4.9(8))
elsif (Ekind (P_Entity) = E_Variable
or else
Ekind (P_Entity) = E_Constant)
elsif Ekind_In (P_Entity, E_Variable, E_Constant)
and then Is_Array_Type (Etype (P_Entity))
and then (not Is_Generic_Type (Etype (P_Entity)))
then
@ -7935,27 +7936,6 @@ package body Sem_Attr is
Fold_Uint (N, 4 * Mantissa, Static);
----------------
-- Enum_Image --
----------------
-- Enum_Image is always static and always has a string literal result
when Attribute_Enum_Image =>
declare
Lit : constant Entity_Id := Entity (E1);
Str : String_Id;
begin
Start_String;
Get_Unqualified_Decoded_Name_String (Chars (Lit));
Set_Casing (All_Upper_Case);
Store_String_Chars (Name_Buffer (1 .. Name_Len));
Str := End_String;
Rewrite (N, Make_String_Literal (Loc, Strval => Str));
Analyze_And_Resolve (N, Standard_String);
Set_Is_Static_Expression (N, True);
end;
--------------
-- Enum_Rep --
--------------
@ -8181,16 +8161,6 @@ package body Sem_Attr is
end;
end if;
---------
-- Img --
---------
-- Img is a scalar attribute, but is never static, because it is
-- not a static function (having a non-scalar argument (RM 4.9(22))
when Attribute_Img =>
null;
-------------------
-- Integer_Value --
-------------------
@ -9646,7 +9616,8 @@ package body Sem_Attr is
-- The following attributes can never be folded, and furthermore we
-- should not even have entered the case statement for any of these.
-- Note that in some cases, the values have already been folded as
-- a result of the processing in Analyze_Attribute.
-- a result of the processing in Analyze_Attribute or earlier in
-- this procedure.
when Attribute_Abort_Signal |
Attribute_Access |
@ -9673,6 +9644,7 @@ package body Sem_Attr is
Attribute_External_Tag |
Attribute_Fast_Math |
Attribute_First_Bit |
Attribute_Img |
Attribute_Input |
Attribute_Last_Bit |
Attribute_Library_Level |