diff options
Diffstat (limited to 'gcc/ada/sem_attr.adb')
| -rw-r--r-- | gcc/ada/sem_attr.adb | 93 |
1 files changed, 77 insertions, 16 deletions
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 1306779d12a..e0c05fd62ae 100644 --- a/gcc/ada/sem_attr.adb +++ b/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 |