diff options
| -rw-r--r-- | gcc/ada/sem_attr.adb | 38 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 60 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 7 |
3 files changed, 94 insertions, 11 deletions
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index df2475f..d012418 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -525,7 +525,7 @@ package body Sem_Attr is -- Object or label reference - elsif Is_Object (Ent) or else Ekind (Ent) = E_Label then + elsif Is_Object_Reference (P) or else Ekind (Ent) = E_Label then Set_Address_Taken (Ent); -- Deal with No_Implicit_Aliasing restriction @@ -3486,11 +3486,25 @@ package body Sem_Attr is return; end if; - -- Normal (non-obsolescent case) of application to object of + -- Normal (non-obsolescent case) of application to object or value of -- a discriminated type. else - Check_Object_Reference (P); + -- AI12-0068: In a type or subtype aspect, a prefix denoting the + -- current instance of the (sub)type is defined to be a value, + -- not an object, so the Constrained attribute is always True + -- (see RM 8.6(18/5) and RM 3.7.2(3/5)). We issue a warning about + -- this unintuitive result, to help avoid confusion. + + if Is_Current_Instance_Reference_In_Type_Aspect (P) then + Error_Msg_Name_1 := Aname; + Error_Msg_N + ("current instance attribute % in subtype aspect always " & + "true??", N); + + else + Check_Object_Reference (P); + end if; -- If N does not come from source, then we allow the -- the attribute prefix to be of a private type whose @@ -4169,11 +4183,13 @@ package body Sem_Attr is if Comes_From_Source (N) then - -- A similar attribute Valid_Scalars can be prefixed with - -- references to both functions and objects, but this attribute - -- can be only prefixed with references to objects. + -- This attribute be prefixed with references to objects or + -- values (such as a current instance value given within a type + -- or subtype aspect). - if not Is_Object_Reference (P) then + if not Is_Object_Reference (P) + and then not Is_Current_Instance_Reference_In_Type_Aspect (P) + then Error_Attr_P ("prefix of % attribute must be object"); end if; end if; @@ -7745,11 +7761,13 @@ package body Sem_Attr is 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). + -- Special processing for cases where the prefix is an object or value, + -- including string literals (attributes of string literals can only + -- appear in generated code) and current instance prefixes in type or + -- subtype aspects. if Is_Object_Reference (P) + or else Is_Current_Instance_Reference_In_Type_Aspect (P) or else Nkind (P) = N_String_Literal or else (Is_Entity_Name (P) and then Ekind (Entity (P)) = E_Enumeration_Literal) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 40f34fd..7ce78a2 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -15029,6 +15029,59 @@ package body Sem_Util is return False; end Is_Current_Instance; + -------------------------------------------------- + -- Is_Current_Instance_Reference_In_Type_Aspect -- + -------------------------------------------------- + + function Is_Current_Instance_Reference_In_Type_Aspect + (N : Node_Id) return Boolean + is + begin + -- When a current_instance is referenced within an aspect_specification + -- of a type or subtype, it will show up as a reference to the formal + -- parameter of the aspect's associated subprogram rather than as a + -- reference to the type or subtype itself (in fact, the original name + -- is never even analyzed). We check for predicate, invariant, and + -- Default_Initial_Condition subprograms (in theory there could be + -- other cases added, in which case this function will need updating). + + if Is_Entity_Name (N) then + return Present (Entity (N)) + and then Ekind (Entity (N)) = E_In_Parameter + and then Ekind_In (Scope (Entity (N)), E_Function, E_Procedure) + and then + (Is_Predicate_Function (Scope (Entity (N))) + or else Is_Predicate_Function_M (Scope (Entity (N))) + or else Is_Invariant_Procedure (Scope (Entity (N))) + or else Is_Partial_Invariant_Procedure (Scope (Entity (N))) + or else Is_DIC_Procedure (Scope (Entity (N)))); + + else + case Nkind (N) is + when N_Indexed_Component + | N_Slice + => + return + Is_Current_Instance_Reference_In_Type_Aspect (Prefix (N)); + + when N_Selected_Component => + return + Is_Current_Instance_Reference_In_Type_Aspect (Prefix (N)); + + when N_Type_Conversion => + return Is_Current_Instance_Reference_In_Type_Aspect + (Expression (N)); + + when N_Qualified_Expression => + return Is_Current_Instance_Reference_In_Type_Aspect + (Expression (N)); + + when others => + return False; + end case; + end if; + end Is_Current_Instance_Reference_In_Type_Aspect; + -------------------- -- Is_Declaration -- -------------------- @@ -16983,8 +17036,13 @@ package body Sem_Util is function Is_Object_Reference (N : Node_Id) return Boolean is begin + -- AI12-0068: Note that a current instance reference in a type or + -- subtype's aspect_specification is considered a value, not an object + -- (see RM 8.6(18/5)). + if Is_Entity_Name (N) then - return Present (Entity (N)) and then Is_Object (Entity (N)); + return Present (Entity (N)) and then Is_Object (Entity (N)) + and then not Is_Current_Instance_Reference_In_Type_Aspect (N); else case Nkind (N) is diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index d99edea..df7e62c 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1693,6 +1693,13 @@ package Sem_Util is -- declarations. In Ada 2012 it also covers type and subtype declarations -- with aspects: Invariant, Predicate, and Default_Initial_Condition. + function Is_Current_Instance_Reference_In_Type_Aspect + (N : Node_Id) return Boolean; + -- True if N is a reference to a current instance object that occurs within + -- an aspect_specification for a type or subtype. In this case N will be + -- a formal parameter of a subprogram created for a predicate, invariant, + -- or Default_Initial_Condition aspect. + function Is_Declaration (N : Node_Id; Body_OK : Boolean := True; |