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 ...@@ -71,6 +71,8 @@ package System.Fat_Gen is
function Machine (X : T) return T; function Machine (X : T) return T;
function Machine_Rounding (X : T) return T;
function Model (X : T) return T; function Model (X : T) return T;
function Pred (X : T) return T; function Pred (X : T) return T;
...@@ -95,6 +97,8 @@ package System.Fat_Gen is ...@@ -95,6 +97,8 @@ package System.Fat_Gen is
-- register, and the whole point of 'Valid is to prevent exceptions. -- register, and the whole point of 'Valid is to prevent exceptions.
-- Note that the object of type T must have the natural alignment -- Note that the object of type T must have the natural alignment
-- for type T. See Unaligned_Valid for further discussion. -- 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; function Unaligned_Valid (A : System.Address) return Boolean;
-- This version of Valid is used if the floating-point value to -- This version of Valid is used if the floating-point value to
...@@ -112,11 +116,16 @@ package System.Fat_Gen is ...@@ -112,11 +116,16 @@ package System.Fat_Gen is
-- not require strict alignment (e.g. the ia32/x86), since on a -- not require strict alignment (e.g. the ia32/x86), since on a
-- target not requiring strict alignment, it is fine to pass a -- target not requiring strict alignment, it is fine to pass a
-- non-aligned value to the standard Valid routine. -- non-aligned value to the standard Valid routine.
--
-- Note: this routine does not work for Vax_Float ???
private private
pragma Inline (Machine); pragma Inline (Machine);
pragma Inline (Model); 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; end System.Fat_Gen;
gcc/ada/s-vaflop-vms-alpha.adb
...@@ -626,7 +626,7 @@ package body System.Vax_Float_Operations is ...@@ -626,7 +626,7 @@ package body System.Vax_Float_Operations is
-- accurate, but is good enough in practice. -- accurate, but is good enough in practice.
function Valid_D (Arg : D) return Boolean is 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 begin
return Val'Valid; return Val'Valid;
end Valid_D; end Valid_D;
...@@ -639,7 +639,7 @@ package body System.Vax_Float_Operations is ...@@ -639,7 +639,7 @@ package body System.Vax_Float_Operations is
-- accurate, but is good enough in practice. -- accurate, but is good enough in practice.
function Valid_F (Arg : F) return Boolean is function Valid_F (Arg : F) return Boolean is
Val : S := F_To_S (Arg); Val : constant S := F_To_S (Arg);
begin begin
return Val'Valid; return Val'Valid;
end Valid_F; end Valid_F;
...@@ -652,7 +652,7 @@ package body System.Vax_Float_Operations is ...@@ -652,7 +652,7 @@ package body System.Vax_Float_Operations is
-- accurate, but is good enough in practice. -- accurate, but is good enough in practice.
function Valid_G (Arg : G) return Boolean is function Valid_G (Arg : G) return Boolean is
Val : T := G_To_T (Arg); Val : constant T := G_To_T (Arg);
begin begin
return Val'Valid; return Val'Valid;
end Valid_G; end Valid_G;
......
gcc/ada/sem_attr.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -492,9 +492,16 @@ package body Sem_Attr is ...@@ -492,9 +492,16 @@ package body Sem_Attr is
-- accesses are allowed (references to the current type instance). -- accesses are allowed (references to the current type instance).
if Is_Entity_Name (P) then if Is_Entity_Name (P) then
Scop := Current_Scope;
Typ := Entity (P); 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 if Is_Type (Typ) then
-- OK if we are within the scope of a limited type -- OK if we are within the scope of a limited type
...@@ -516,6 +523,7 @@ package body Sem_Attr is ...@@ -516,6 +523,7 @@ package body Sem_Attr is
loop loop
Q := Parent (Q); Q := Parent (Q);
end loop; end loop;
if Present (Q) then if Present (Q) then
Set_Has_Per_Object_Constraint ( Set_Has_Per_Object_Constraint (
Defining_Identifier (Q), True); Defining_Identifier (Q), True);
...@@ -585,11 +593,9 @@ package body Sem_Attr is ...@@ -585,11 +593,9 @@ package body Sem_Attr is
declare declare
Index : Interp_Index; Index : Interp_Index;
It : Interp; It : Interp;
begin begin
Set_Etype (N, Any_Type); Set_Etype (N, Any_Type);
Get_First_Interp (P, Index, It); Get_First_Interp (P, Index, It);
while Present (It.Typ) loop while Present (It.Typ) loop
Acc_Type := Build_Access_Object_Type (It.Typ); Acc_Type := Build_Access_Object_Type (It.Typ);
Add_One_Interp (N, Acc_Type, Acc_Type); Add_One_Interp (N, Acc_Type, Acc_Type);
...@@ -1373,13 +1379,27 @@ package body Sem_Attr is ...@@ -1373,13 +1379,27 @@ package body Sem_Attr is
begin begin
Analyze (P); Analyze (P);
-- Ada 2005 (AI-345): Attribute 'Terminated can be applied to
-- task interface class-wide types.
if Is_Task_Type (Etype (P)) if Is_Task_Type (Etype (P))
or else (Is_Access_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 then
Resolve (P); Resolve (P);
else 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 if;
end Check_Task_Prefix; end Check_Task_Prefix;
...@@ -2793,16 +2813,28 @@ package body Sem_Attr is ...@@ -2793,16 +2813,28 @@ package body Sem_Attr is
if Etype (P) = Standard_Exception_Type then if Etype (P) = Standard_Exception_Type then
Set_Etype (N, RTE (RE_Exception_Id)); 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)) elsif Is_Task_Type (Etype (P))
or else (Is_Access_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 then
Resolve (P); Resolve (P);
Set_Etype (N, RTE (RO_AT_Task_Id)); Set_Etype (N, RTE (RO_AT_Task_Id));
else else
Error_Attr ("prefix of % attribute must be a task or an " if Ada_Version >= Ada_05 then
& "exception", P); 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; end if;
----------- -----------
...@@ -2962,6 +2994,15 @@ package body Sem_Attr is ...@@ -2962,6 +2994,15 @@ package body Sem_Attr is
Check_E0; Check_E0;
Set_Etype (N, Universal_Integer); 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 -- -- Machine_Rounds --
-------------------- --------------------
...@@ -5481,6 +5522,20 @@ package body Sem_Attr is ...@@ -5481,6 +5522,20 @@ package body Sem_Attr is
Fold_Uint (N, Uint_2, True); Fold_Uint (N, Uint_2, True);
end if; 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 -- -- Machine_Rounds --
-------------------- --------------------
...@@ -6243,7 +6298,6 @@ package body Sem_Attr is ...@@ -6243,7 +6298,6 @@ package body Sem_Attr is
end if; end if;
Rewrite (N, New_Occurrence_Of (RTE (Id), Loc)); Rewrite (N, New_Occurrence_Of (RTE (Id), Loc));
end Type_Class; end Type_Class;
----------------------- -----------------------
...@@ -7685,12 +7739,19 @@ package body Sem_Attr is ...@@ -7685,12 +7739,19 @@ package body Sem_Attr is
return True; return True;
end if; end if;
if Nam = TSS_Stream_Input then -- In Ada 2005, Input can invoke Read, and Output can invoke Write
return Ada_Version >= Ada_05
and then Stream_Attribute_Available (Etyp, TSS_Stream_Read); if Nam = TSS_Stream_Input
elsif Nam = TSS_Stream_Output then and then Ada_Version >= Ada_05
return Ada_Version >= Ada_05 and then Stream_Attribute_Available (Etyp, TSS_Stream_Read)
and then Stream_Attribute_Available (Etyp, TSS_Stream_Write); 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; end if;
-- Case of Read and Write: check for attribute definition clause that -- 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); ...@@ -95,91 +95,92 @@ extern unsigned char Get_Attribute_Id (int);
#define Attr_Machine_Mantissa 47 #define Attr_Machine_Mantissa 47
#define Attr_Machine_Overflows 48 #define Attr_Machine_Overflows 48
#define Attr_Machine_Radix 49 #define Attr_Machine_Radix 49
#define Attr_Machine_Rounds 50 #define Attr_Machine_Rounding 50
#define Attr_Machine_Size 51 #define Attr_Machine_Rounds 51
#define Attr_Mantissa 52 #define Attr_Machine_Size 52
#define Attr_Max_Size_In_Storage_Elements 53 #define Attr_Mantissa 53
#define Attr_Maximum_Alignment 54 #define Attr_Max_Size_In_Storage_Elements 54
#define Attr_Mechanism_Code 55 #define Attr_Maximum_Alignment 55
#define Attr_Mod 56 #define Attr_Mechanism_Code 56
#define Attr_Model_Emin 57 #define Attr_Mod 57
#define Attr_Model_Epsilon 58 #define Attr_Model_Emin 58
#define Attr_Model_Mantissa 59 #define Attr_Model_Epsilon 59
#define Attr_Model_Small 60 #define Attr_Model_Mantissa 60
#define Attr_Modulus 61 #define Attr_Model_Small 61
#define Attr_Null_Parameter 62 #define Attr_Modulus 62
#define Attr_Object_Size 63 #define Attr_Null_Parameter 63
#define Attr_Partition_ID 64 #define Attr_Object_Size 64
#define Attr_Passed_By_Reference 65 #define Attr_Partition_ID 65
#define Attr_Pool_Address 66 #define Attr_Passed_By_Reference 66
#define Attr_Pos 67 #define Attr_Pool_Address 67
#define Attr_Position 68 #define Attr_Pos 68
#define Attr_Range 69 #define Attr_Position 69
#define Attr_Range_Length 70 #define Attr_Range 70
#define Attr_Round 71 #define Attr_Range_Length 71
#define Attr_Safe_Emax 72 #define Attr_Round 72
#define Attr_Safe_First 73 #define Attr_Safe_Emax 73
#define Attr_Safe_Large 74 #define Attr_Safe_First 74
#define Attr_Safe_Last 75 #define Attr_Safe_Large 75
#define Attr_Safe_Small 76 #define Attr_Safe_Last 76
#define Attr_Scale 77 #define Attr_Safe_Small 77
#define Attr_Scaling 78 #define Attr_Scale 78
#define Attr_Signed_Zeros 79 #define Attr_Scaling 79
#define Attr_Size 80 #define Attr_Signed_Zeros 80
#define Attr_Small 81 #define Attr_Size 81
#define Attr_Storage_Size 82 #define Attr_Small 82
#define Attr_Storage_Unit 83 #define Attr_Storage_Size 83
#define Attr_Stream_Size 84 #define Attr_Storage_Unit 84
#define Attr_Tag 85 #define Attr_Stream_Size 85
#define Attr_Target_Name 86 #define Attr_Tag 86
#define Attr_Terminated 87 #define Attr_Target_Name 87
#define Attr_To_Address 88 #define Attr_Terminated 88
#define Attr_Type_Class 89 #define Attr_To_Address 89
#define Attr_UET_Address 90 #define Attr_Type_Class 90
#define Attr_Unbiased_Rounding 91 #define Attr_UET_Address 91
#define Attr_Unchecked_Access 92 #define Attr_Unbiased_Rounding 92
#define Attr_Unconstrained_Array 93 #define Attr_Unchecked_Access 93
#define Attr_Universal_Literal_String 94 #define Attr_Unconstrained_Array 94
#define Attr_Unrestricted_Access 95 #define Attr_Universal_Literal_String 95
#define Attr_VADS_Size 96 #define Attr_Unrestricted_Access 96
#define Attr_Val 97 #define Attr_VADS_Size 97
#define Attr_Valid 98 #define Attr_Val 98
#define Attr_Value_Size 99 #define Attr_Valid 99
#define Attr_Version 100 #define Attr_Value_Size 100
#define Attr_Wchar_T_Size 101 #define Attr_Version 101
#define Attr_Wide_Wide_Width 102 #define Attr_Wchar_T_Size 102
#define Attr_Wide_Width 103 #define Attr_Wide_Wide_Width 103
#define Attr_Width 104 #define Attr_Wide_Width 104
#define Attr_Word_Size 105 #define Attr_Width 105
#define Attr_Adjacent 106 #define Attr_Word_Size 106
#define Attr_Ceiling 107 #define Attr_Adjacent 107
#define Attr_Copy_Sign 108 #define Attr_Ceiling 108
#define Attr_Floor 109 #define Attr_Copy_Sign 109
#define Attr_Fraction 110 #define Attr_Floor 110
#define Attr_Image 111 #define Attr_Fraction 111
#define Attr_Input 112 #define Attr_Image 112
#define Attr_Machine 113 #define Attr_Input 113
#define Attr_Max 114 #define Attr_Machine 114
#define Attr_Min 115 #define Attr_Max 115
#define Attr_Model 116 #define Attr_Min 116
#define Attr_Pred 117 #define Attr_Model 117
#define Attr_Remainder 118 #define Attr_Pred 118
#define Attr_Rounding 119 #define Attr_Remainder 119
#define Attr_Succ 120 #define Attr_Rounding 120
#define Attr_Truncation 121 #define Attr_Succ 121
#define Attr_Value 122 #define Attr_Truncation 122
#define Attr_Wide_Image 123 #define Attr_Value 123
#define Attr_Wide_Wide_Image 124 #define Attr_Wide_Image 124
#define Attr_Wide_Value 125 #define Attr_Wide_Wide_Image 125
#define Attr_Wide_Wide_Value 126 #define Attr_Wide_Value 126
#define Attr_Output 127 #define Attr_Wide_Wide_Value 127
#define Attr_Read 128 #define Attr_Output 128
#define Attr_Write 129 #define Attr_Read 129
#define Attr_Elab_Body 130 #define Attr_Write 130
#define Attr_Elab_Spec 131 #define Attr_Elab_Body 131
#define Attr_Storage_Pool 132 #define Attr_Elab_Spec 132
#define Attr_Base 133 #define Attr_Storage_Pool 133
#define Attr_Class 134 #define Attr_Base 134
#define Attr_Class 135
/* Define the numeric values for the conventions. */ /* 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