diff options
Diffstat (limited to 'gcc/ada/sem_attr.adb')
| -rw-r--r-- | gcc/ada/sem_attr.adb | 133 |
1 files changed, 5 insertions, 128 deletions
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index cca6f6f..7c76f0f 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -25,6 +25,7 @@ with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; +with Accessibility; use Accessibility; with Aspects; use Aspects; with Atree; use Atree; with Casing; use Casing; @@ -10936,72 +10937,12 @@ package body Sem_Attr is It : Interp; Nom_Subt : Entity_Id; - procedure Accessibility_Message; - -- Error, or warning within an instance, if the static accessibility - -- rules of 3.10.2 are violated. - function Declared_Within_Generic_Unit (Entity : Entity_Id; Generic_Unit : Node_Id) return Boolean; -- Returns True if Declared_Entity is declared within the declarative -- region of Generic_Unit; otherwise returns False. - function Prefix_With_Safe_Accessibility_Level return Boolean; - -- Return True if the prefix does not have a value conversion of an - -- array because a value conversion is like an aggregate with respect - -- to determining accessibility level (RM 3.10.2); even if evaluation - -- of a value conversion is guaranteed to not create a new object, - -- accessibility rules are defined as if it might. - - --------------------------- - -- Accessibility_Message -- - --------------------------- - - procedure Accessibility_Message is - Indic : Node_Id := Parent (Parent (N)); - - begin - -- In an instance, this is a runtime check, but one we - -- know will fail, so generate an appropriate warning. - - if In_Instance_Body then - Error_Msg_Warn := SPARK_Mode /= On; - Error_Msg_F - ("non-local pointer cannot point to local object<<", P); - Error_Msg_F ("\Program_Error [<<", P); - Rewrite (N, - Make_Raise_Program_Error (Loc, - Reason => PE_Accessibility_Check_Failed)); - Set_Etype (N, Typ); - return; - - else - Error_Msg_F ("non-local pointer cannot point to local object", P); - - -- Check for case where we have a missing access definition - - if Is_Record_Type (Current_Scope) - and then - Nkind (Parent (N)) in N_Discriminant_Association - | N_Index_Or_Discriminant_Constraint - then - Indic := Parent (Parent (N)); - while Present (Indic) - and then Nkind (Indic) /= N_Subtype_Indication - loop - Indic := Parent (Indic); - end loop; - - if Present (Indic) then - Error_Msg_NE - ("\use an access definition for" & - " the access discriminant of&", - N, Entity (Subtype_Mark (Indic))); - end if; - end if; - end if; - end Accessibility_Message; - ---------------------------------- -- Declared_Within_Generic_Unit -- ---------------------------------- @@ -11029,70 +10970,6 @@ package body Sem_Attr is return False; end Declared_Within_Generic_Unit; - ------------------------------------------ - -- Prefix_With_Safe_Accessibility_Level -- - ------------------------------------------ - - function Prefix_With_Safe_Accessibility_Level return Boolean is - function Safe_Value_Conversions return Boolean; - -- Return False if the prefix has a value conversion of an array type - - ---------------------------- - -- Safe_Value_Conversions -- - ---------------------------- - - function Safe_Value_Conversions return Boolean is - PP : Node_Id := P; - - begin - loop - if Nkind (PP) in N_Selected_Component | N_Indexed_Component then - PP := Prefix (PP); - - elsif Comes_From_Source (PP) - and then Nkind (PP) in N_Type_Conversion - | N_Unchecked_Type_Conversion - and then Is_Array_Type (Etype (PP)) - then - return False; - - elsif Comes_From_Source (PP) - and then Nkind (PP) = N_Qualified_Expression - and then Is_Array_Type (Etype (PP)) - and then Nkind (Original_Node (Expression (PP))) in - N_Aggregate | N_Extension_Aggregate - then - return False; - - else - exit; - end if; - end loop; - - return True; - end Safe_Value_Conversions; - - -- Start of processing for Prefix_With_Safe_Accessibility_Level - - begin - -- No check required for unchecked and unrestricted access - - if Attr_Id = Attribute_Unchecked_Access - or else Attr_Id = Attribute_Unrestricted_Access - then - return True; - - -- Check value conversions - - elsif Ekind (Btyp) = E_General_Access_Type - and then not Safe_Value_Conversions - then - return False; - end if; - - return True; - end Prefix_With_Safe_Accessibility_Level; - -- Start of processing for Resolve_Attribute begin @@ -11778,7 +11655,7 @@ package body Sem_Attr is Intval (Accessibility_Level (P, Dynamic_Level)) > Deepest_Type_Access_Level (Btyp) then - Accessibility_Message; + Accessibility_Message (N, Typ); return; end if; end; @@ -11804,7 +11681,7 @@ package body Sem_Attr is and then Ekind (Btyp) = E_Access_Protected_Subprogram_Type and then Attr_Id /= Attribute_Unrestricted_Access then - Accessibility_Message; + Accessibility_Message (N, Typ); return; -- AI05-0225: If the context is not an access to protected @@ -11963,8 +11840,8 @@ package body Sem_Attr is -- array type since a value conversion is like an aggregate with -- respect to determining accessibility level (RM 3.10.2). - if not Prefix_With_Safe_Accessibility_Level then - Accessibility_Message; + if not Prefix_With_Safe_Accessibility_Level (N, Typ) then + Accessibility_Message (N, Typ); return; end if; |