Skip to content

R
riscv-gcc-1
Commit 65f01153 by Robert Dewar Committed by Arnaud Charlet
Options

sem_attr.adb: Implement Machine_Rounding attribute 

2005-11-14  Robert Dewar  <dewar@adacore.com>
	    Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_attr.adb: Implement Machine_Rounding attribute
	(Analyze_Access_Attribute): The access attribute may appear within an
	aggregate that has been expanded into a loop.
	(Check_Task_Prefix): Add semantic check for attribute 'Callable and
	'Terminated whenever the prefix is of a task interface class-wide type.
	(Analyze_Attribute): Add semantic check for attribute 'Identity whenever
	the prefix is of a task interface class-wide type.

	* s-vaflop-vms-alpha.adb: Valid_D, Valid_F, Valid_G: Make Val constant
	to avoid warnings.

	* s-fatgen.ads, s-fatgen.adb (Machine_Rounding): New function
	Remove pragma Inline for [Unaligned_]Valid.
	Add comments that Valid routines do not work for Vax_Float

	* exp_attr.adb: Implement Machine_Rounding attribute

	* snames.h: Add entry for Machine_Rounding attribute

From-SVN: r106970
parent 7b9d0d69
Showing with 250 additions and 154 deletions
gcc/ada/s-fatgen.ads
......@@ -71,6 +71,8 @@ package System.Fat_Gen is
function Machine (X : T) return T;
function Machine_Rounding (X : T) return T;
function Model (X : T) return T;
function Pred (X : T) return T;
......@@ -95,6 +97,8 @@ package System.Fat_Gen is
-- register, and the whole point of 'Valid is to prevent exceptions.
-- Note that the object of type T must have the natural alignment
-- for type T. See Unaligned_Valid for further discussion.
--
-- Note: this routine does not work for Vax_Float ???
function Unaligned_Valid (A : System.Address) return Boolean;
-- This version of Valid is used if the floating-point value to
......@@ -112,11 +116,16 @@ package System.Fat_Gen is
-- not require strict alignment (e.g. the ia32/x86), since on a
-- target not requiring strict alignment, it is fine to pass a
-- non-aligned value to the standard Valid routine.
--
-- Note: this routine does not work for Vax_Float ???
private
pragma Inline (Machine);
pragma Inline (Model);
pragma Inline_Always (Valid);
pragma Inline_Always (Unaligned_Valid);
-- Note: previously the validity checking subprograms (Unaligned_Valid and
-- Valid) were also inlined, but this was changed since there were some
-- problems with this inlining in optimized mode, and in any case it seems
-- better to avoid this inlining (space and robustness considerations).
end System.Fat_Gen;
gcc/ada/s-vaflop-vms-alpha.adb
......@@ -626,7 +626,7 @@ package body System.Vax_Float_Operations is
-- accurate, but is good enough in practice.
function Valid_D (Arg : D) return Boolean is
Val : T := G_To_T (D_To_G (Arg));
Val : constant T := G_To_T (D_To_G (Arg));
begin
return Val'Valid;
end Valid_D;
......@@ -639,7 +639,7 @@ package body System.Vax_Float_Operations is
-- accurate, but is good enough in practice.
function Valid_F (Arg : F) return Boolean is
Val : S := F_To_S (Arg);
Val : constant S := F_To_S (Arg);
begin
return Val'Valid;
end Valid_F;
......@@ -652,7 +652,7 @@ package body System.Vax_Float_Operations is
-- accurate, but is good enough in practice.
function Valid_G (Arg : G) return Boolean is
Val : T := G_To_T (Arg);
Val : constant T := G_To_T (Arg);
begin
return Val'Valid;
end Valid_G;
......
gcc/ada/sem_attr.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, 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- --
......@@ -492,9 +492,16 @@ package body Sem_Attr is
-- accesses are allowed (references to the current type instance).
if Is_Entity_Name (P) then
Scop := Current_Scope;
Typ := Entity (P);
-- The reference may appear in an aggregate that has been expanded
-- into a loop. Locate scope of type definition, if any.
Scop := Current_Scope;
while Ekind (Scop) = E_Loop loop
Scop := Scope (Scop);
end loop;
if Is_Type (Typ) then
-- OK if we are within the scope of a limited type
......@@ -516,6 +523,7 @@ package body Sem_Attr is
loop
Q := Parent (Q);
end loop;
if Present (Q) then
Set_Has_Per_Object_Constraint (
Defining_Identifier (Q), True);
......@@ -585,11 +593,9 @@ package body Sem_Attr is
declare
Index : Interp_Index;
It : Interp;
begin
Set_Etype (N, Any_Type);
Get_First_Interp (P, Index, It);
while Present (It.Typ) loop
Acc_Type := Build_Access_Object_Type (It.Typ);
Add_One_Interp (N, Acc_Type, Acc_Type);
......@@ -1373,13 +1379,27 @@ package body Sem_Attr is
begin
Analyze (P);
-- Ada 2005 (AI-345): Attribute 'Terminated can be applied to
-- task interface class-wide types.
if Is_Task_Type (Etype (P))
or else (Is_Access_Type (Etype (P))
and then Is_Task_Type (Designated_Type (Etype (P))))
and then Is_Task_Type (Designated_Type (Etype (P))))
or else (Ada_Version >= Ada_05
and then Ekind (Etype (P)) = E_Class_Wide_Type
and then Is_Interface (Etype (P))
and then Is_Task_Interface (Etype (P)))
then
Resolve (P);
else
Error_Attr ("prefix of % attribute must be a task", P);
if Ada_Version >= Ada_05 then
Error_Attr ("prefix of % attribute must be a task or a task "
& "interface class-wide object", P);
else
Error_Attr ("prefix of % attribute must be a task", P);
end if;
end if;
end Check_Task_Prefix;
......@@ -2793,16 +2813,28 @@ package body Sem_Attr is
if Etype (P) = Standard_Exception_Type then
Set_Etype (N, RTE (RE_Exception_Id));
-- Ada 2005 (AI-345): Attribute 'Identity may be applied to
-- task interface class-wide types.
elsif Is_Task_Type (Etype (P))
or else (Is_Access_Type (Etype (P))
and then Is_Task_Type (Designated_Type (Etype (P))))
and then Is_Task_Type (Designated_Type (Etype (P))))
or else (Ada_Version >= Ada_05
and then Ekind (Etype (P)) = E_Class_Wide_Type
and then Is_Interface (Etype (P))
and then Is_Task_Interface (Etype (P)))
then
Resolve (P);
Set_Etype (N, RTE (RO_AT_Task_Id));
else
Error_Attr ("prefix of % attribute must be a task or an "
& "exception", P);
if Ada_Version >= Ada_05 then
Error_Attr ("prefix of % attribute must be an exception, a "
& "task or a task interface class-wide object", P);
else
Error_Attr ("prefix of % attribute must be a task or an "
& "exception", P);
end if;
end if;
-----------
......@@ -2962,6 +2994,15 @@ package body Sem_Attr is
Check_E0;
Set_Etype (N, Universal_Integer);
----------------------
-- Machine_Rounding --
----------------------
when Attribute_Machine_Rounding =>
Check_Floating_Point_Type_1;
Set_Etype (N, P_Base_Type);
Resolve (E1, P_Base_Type);
--------------------
-- Machine_Rounds --
--------------------
......@@ -5481,6 +5522,20 @@ package body Sem_Attr is
Fold_Uint (N, Uint_2, True);
end if;
----------------------
-- Machine_Rounding --
----------------------
-- Note: for the folding case, it is fine to treat Machine_Rounding
-- exactly the same way as Rounding, since this is one of the allowed
-- behaviors, and performance is not an issue here. It might be a bit
-- better to give the same result as it would give at run-time, even
-- though the non-determinism is certainly permitted.
when Attribute_Machine_Rounding =>
Fold_Ureal (N,
Eval_Fat.Rounding (P_Root_Type, Expr_Value_R (E1)), Static);
--------------------
-- Machine_Rounds --
--------------------
......@@ -6243,7 +6298,6 @@ package body Sem_Attr is
end if;
Rewrite (N, New_Occurrence_Of (RTE (Id), Loc));
end Type_Class;
-----------------------
......@@ -7685,12 +7739,19 @@ package body Sem_Attr is
return True;
end if;
if Nam = TSS_Stream_Input then
return Ada_Version >= Ada_05
and then Stream_Attribute_Available (Etyp, TSS_Stream_Read);
elsif Nam = TSS_Stream_Output then
return Ada_Version >= Ada_05
and then Stream_Attribute_Available (Etyp, TSS_Stream_Write);
-- In Ada 2005, Input can invoke Read, and Output can invoke Write
if Nam = TSS_Stream_Input
and then Ada_Version >= Ada_05
and then Stream_Attribute_Available (Etyp, TSS_Stream_Read)
then
return True;
elsif Nam = TSS_Stream_Output
and then Ada_Version >= Ada_05
and then Stream_Attribute_Available (Etyp, TSS_Stream_Write)
then
return True;
end if;
-- Case of Read and Write: check for attribute definition clause that
......
gcc/ada/snames.h
......@@ -95,91 +95,92 @@ extern unsigned char Get_Attribute_Id (int);
#define Attr_Machine_Mantissa 47
#define Attr_Machine_Overflows 48
#define Attr_Machine_Radix 49
#define Attr_Machine_Rounds 50
#define Attr_Machine_Size 51
#define Attr_Mantissa 52
#define Attr_Max_Size_In_Storage_Elements 53
#define Attr_Maximum_Alignment 54
#define Attr_Mechanism_Code 55
#define Attr_Mod 56
#define Attr_Model_Emin 57
#define Attr_Model_Epsilon 58
#define Attr_Model_Mantissa 59
#define Attr_Model_Small 60
#define Attr_Modulus 61
#define Attr_Null_Parameter 62
#define Attr_Object_Size 63
#define Attr_Partition_ID 64
#define Attr_Passed_By_Reference 65
#define Attr_Pool_Address 66
#define Attr_Pos 67
#define Attr_Position 68
#define Attr_Range 69
#define Attr_Range_Length 70
#define Attr_Round 71
#define Attr_Safe_Emax 72
#define Attr_Safe_First 73
#define Attr_Safe_Large 74
#define Attr_Safe_Last 75
#define Attr_Safe_Small 76
#define Attr_Scale 77
#define Attr_Scaling 78
#define Attr_Signed_Zeros 79
#define Attr_Size 80
#define Attr_Small 81
#define Attr_Storage_Size 82
#define Attr_Storage_Unit 83
#define Attr_Stream_Size 84
#define Attr_Tag 85
#define Attr_Target_Name 86
#define Attr_Terminated 87
#define Attr_To_Address 88
#define Attr_Type_Class 89
#define Attr_UET_Address 90
#define Attr_Unbiased_Rounding 91
#define Attr_Unchecked_Access 92
#define Attr_Unconstrained_Array 93
#define Attr_Universal_Literal_String 94
#define Attr_Unrestricted_Access 95
#define Attr_VADS_Size 96
#define Attr_Val 97
#define Attr_Valid 98
#define Attr_Value_Size 99
#define Attr_Version 100
#define Attr_Wchar_T_Size 101
#define Attr_Wide_Wide_Width 102
#define Attr_Wide_Width 103
#define Attr_Width 104
#define Attr_Word_Size 105
#define Attr_Adjacent 106
#define Attr_Ceiling 107
#define Attr_Copy_Sign 108
#define Attr_Floor 109
#define Attr_Fraction 110
#define Attr_Image 111
#define Attr_Input 112
#define Attr_Machine 113
#define Attr_Max 114
#define Attr_Min 115
#define Attr_Model 116
#define Attr_Pred 117
#define Attr_Remainder 118
#define Attr_Rounding 119
#define Attr_Succ 120
#define Attr_Truncation 121
#define Attr_Value 122
#define Attr_Wide_Image 123
#define Attr_Wide_Wide_Image 124
#define Attr_Wide_Value 125
#define Attr_Wide_Wide_Value 126
#define Attr_Output 127
#define Attr_Read 128
#define Attr_Write 129
#define Attr_Elab_Body 130
#define Attr_Elab_Spec 131
#define Attr_Storage_Pool 132
#define Attr_Base 133
#define Attr_Class 134
#define Attr_Machine_Rounding 50
#define Attr_Machine_Rounds 51
#define Attr_Machine_Size 52
#define Attr_Mantissa 53
#define Attr_Max_Size_In_Storage_Elements 54
#define Attr_Maximum_Alignment 55
#define Attr_Mechanism_Code 56
#define Attr_Mod 57
#define Attr_Model_Emin 58
#define Attr_Model_Epsilon 59
#define Attr_Model_Mantissa 60
#define Attr_Model_Small 61
#define Attr_Modulus 62
#define Attr_Null_Parameter 63
#define Attr_Object_Size 64
#define Attr_Partition_ID 65
#define Attr_Passed_By_Reference 66
#define Attr_Pool_Address 67
#define Attr_Pos 68
#define Attr_Position 69
#define Attr_Range 70
#define Attr_Range_Length 71
#define Attr_Round 72
#define Attr_Safe_Emax 73
#define Attr_Safe_First 74
#define Attr_Safe_Large 75
#define Attr_Safe_Last 76
#define Attr_Safe_Small 77
#define Attr_Scale 78
#define Attr_Scaling 79
#define Attr_Signed_Zeros 80
#define Attr_Size 81
#define Attr_Small 82
#define Attr_Storage_Size 83
#define Attr_Storage_Unit 84
#define Attr_Stream_Size 85
#define Attr_Tag 86
#define Attr_Target_Name 87
#define Attr_Terminated 88
#define Attr_To_Address 89
#define Attr_Type_Class 90
#define Attr_UET_Address 91
#define Attr_Unbiased_Rounding 92
#define Attr_Unchecked_Access 93
#define Attr_Unconstrained_Array 94
#define Attr_Universal_Literal_String 95
#define Attr_Unrestricted_Access 96
#define Attr_VADS_Size 97
#define Attr_Val 98
#define Attr_Valid 99
#define Attr_Value_Size 100
#define Attr_Version 101
#define Attr_Wchar_T_Size 102
#define Attr_Wide_Wide_Width 103
#define Attr_Wide_Width 104
#define Attr_Width 105
#define Attr_Word_Size 106
#define Attr_Adjacent 107
#define Attr_Ceiling 108
#define Attr_Copy_Sign 109
#define Attr_Floor 110
#define Attr_Fraction 111
#define Attr_Image 112
#define Attr_Input 113
#define Attr_Machine 114
#define Attr_Max 115
#define Attr_Min 116
#define Attr_Model 117
#define Attr_Pred 118
#define Attr_Remainder 119
#define Attr_Rounding 120
#define Attr_Succ 121
#define Attr_Truncation 122
#define Attr_Value 123
#define Attr_Wide_Image 124
#define Attr_Wide_Wide_Image 125
#define Attr_Wide_Value 126
#define Attr_Wide_Wide_Value 127
#define Attr_Output 128
#define Attr_Read 129
#define Attr_Write 130
#define Attr_Elab_Body 131
#define Attr_Elab_Spec 132
#define Attr_Storage_Pool 133
#define Attr_Base 134
#define Attr_Class 135
/* Define the numeric values for the conventions. */
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment