diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/ChangeLog | 99 | ||||
| -rw-r--r-- | gcc/ada/checks.adb | 24 | ||||
| -rw-r--r-- | gcc/ada/einfo.adb | 18 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 12 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 41 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 33 | ||||
| -rw-r--r-- | gcc/ada/exp_ch5.adb | 51 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 59 | ||||
| -rw-r--r-- | gcc/ada/sem_attr.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/sem_ch5.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/sem_ch8.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_disp.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 19 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 113 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 19 |
16 files changed, 477 insertions, 43 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a5892f23f73..9a4bc026579 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,102 @@ +2011-08-30 Steve Baird <baird@adacore.com> + + * sem_util.ads (Deepest_Type_Access_Level): New function; for the type + of a saooaaat (i.e, a stand-alone object of an anonymous access type), + returns the (static) accessibility level of the object. Otherwise, the + same as Type_Access_Level. + (Dynamic_Accessibility_Level): New function; given an expression which + could occur as the rhs of an assignment to a saooaaat (i.e., an + expression of an access-to-object type), return the new value for the + saooaaat's associated Extra_Accessibility object. + (Effective_Extra_Accessibility): New function; same as + Einfo.Extra_Accessibility except that object renames are looked through. + * sem_util.adb + (Deepest_Type_Access_Level): New function; see sem_util.ads description. + (Dynamic_Accessibility_Level): New function; see sem_util.ads + description. + (Effective_Extra_Accessibility): New function; see sem_util.ads + description. + * einfo.ads (Is_Local_Anonymous_Access): Update comments. + (Extra_Accessibility): Update comments. + (Init_Object_Size_Align): New procedure; same as Init_Size_Align + except RM_Size field (which is only for types) is unaffected. + * einfo.adb + (Extra_Accessibility): Expand domain to allow objects, not just formals. + (Set_Extra_Accessibility): Expand domain to allow objects, not just + formals. + (Init_Size): Add assertion that we are not trashing the + Extra_Accessibility attribute of an object. + (Init_Size_Align): Add assertion that we are not trashing the + Extra_Accessibility attribute of an object. + (Init_Object_Size_Align): New procedure; see einfo.ads description. + * sem_ch3.adb (Find_Type_Of_Object): Set Is_Local_Anonymous_Access + differently for the type of a (non-library-level) saooaaat depending + whether Ada_Version < Ada_2012. This is the only point where Ada_Version + is queried in this set of changes - everything else (in particular, + setting of the Extra_Accessibility attribute in exp_ch3.adb) is + driven off of the setting of the Is_Local_Anonymous_Access attribute. + The special treatment of library-level saooaaats is an optimization, + not required for correctnesss. This is based on the observation that the + Ada2012 rules (static and dynamic) for saooaaats turn out to be + equivalent to the Ada2005 rules in the case of a library-level saooaaat. + * exp_ch3.adb + (Expand_N_Object_Declaration): If Is_Local_Anonymous_Access is + false for the type of a saooaaat, declare and initialize its + accessibility level object and set the Extra_Accessibility attribute + of the saooaaat to refer to this object. + * checks.adb (Apply_Accessibility_Check): Add Ada 2012 saooaaat support. + * exp_ch4.adb (Expand_N_In): Replace some Extra_Accessibility calls with + calls to Effective_Extra_Accessibility in order to support + renames of saooaaats. + (Expand_N_Type_Conversion): Add new local function, + Has_Extra_Accessibility, and call it when determining whether an + accessibility check is needed. + It returns True iff Present (Effective_Extra_Accessibility (Id)) would + evaluate to True (without raising an exception). + * exp_ch5.adb + (Expand_N_Assignment_Statement): When assigning to an Ada2012 + saooaaat, update its associated Extra_Accessibility object (if + it has one). This includes an accessibility check. + * exp_ch6.adb (Add_Call_By_Copy_Code): When parameter copy-back updates + a saooaaat, update its Extra_Accessibility object too (if it + has one). + (Expand_Call): Replace a couple of calls to Type_Access_Level + with calls to Dynamic_Access_Level to handle cases where + passing a literal (any literal) is incorrect. + * sem_attr.adb (Resolve_Attribute): Handle the static accessibility + checks associated with "Saooaat := Some_Object'Access;"; this must + be rejected if Some_Object is declared in a more nested scope + than Saooaat. + * sem_ch5.adb (Analyze_Assignment): Force accessibility checking for an + assignment to a saooaaat even if Is_Local_Anonymous_Access + returns False for its type (indicating a 2012-style saooaaat). + * sem_ch8.adb + (Analyze_Object_Renaming): Replace a call to Init_Size_Align + (which is only appropriate for objects, not types) with a call + of Init_Object_Size_Align in order to avoid trashing the + Extra_Accessibility attribute of a rename (the two attributes + share storage). + * sem_res.adb + (Valid_Conversion) Replace six calls to Type_Access_Level with + calls to Deepest_Type_Access_Level. This is a bit tricky. For an + Ada2012 non-library-level saooaaat, the former returns library level + while the latter returns the (static) accessibility level of the + saooaaat. A type conversion to the anonymous type of a saooaaat + can only occur as part of an assignment to the saooaaat, so we + know that such a conversion must be in a lhs context, so Deepest + yields the result that we need. If such a conversion could occur, + say, as the operand of an equality operator, then this might not + be right. Also add a test so that static accessibilty checks are + performed for converting to a saooaaat's type even if + Is_Local_Anonymous_Access yields False for the type. + +2011-08-30 Javier Miranda <miranda@adacore.com> + + * sem_disp.adb (Check_Dispatching_Operation): Complete condition that + controls generation of a warning associated with late declaration of + dispatching functions. Required to avoid generating spurious + warnings. + 2011-08-30 Gary Dismukes <dismukes@adacore.com> * sem_ch6.adb (Check_Return_Subtype_Indication): Issue error if the diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 2f3b11bfed4..a5da4154867 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -479,11 +479,26 @@ package body Checks is Insert_Node : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - Param_Ent : constant Entity_Id := Param_Entity (N); + Param_Ent : Entity_Id := Param_Entity (N); Param_Level : Node_Id; Type_Level : Node_Id; begin + if Ada_Version >= Ada_2012 + and then not Present (Param_Ent) + and then Is_Entity_Name (N) + and then Ekind_In (Entity (N), E_Constant, E_Variable) + and then Present (Effective_Extra_Accessibility (Entity (N))) + then + Param_Ent := Entity (N); + while Present (Renamed_Object (Param_Ent)) loop + -- Renamed_Object must return an Entity_Name here + -- because of preceding "Present (E_E_A (...))" test. + + Param_Ent := Entity (Renamed_Object (Param_Ent)); + end loop; + end if; + if Inside_A_Generic then return; @@ -494,15 +509,16 @@ package body Checks is elsif Present (Param_Ent) and then Present (Extra_Accessibility (Param_Ent)) - and then UI_Gt (Object_Access_Level (N), Type_Access_Level (Typ)) + and then UI_Gt (Object_Access_Level (N), + Deepest_Type_Access_Level (Typ)) and then not Accessibility_Checks_Suppressed (Param_Ent) and then not Accessibility_Checks_Suppressed (Typ) then Param_Level := New_Occurrence_Of (Extra_Accessibility (Param_Ent), Loc); - Type_Level := - Make_Integer_Literal (Loc, Type_Access_Level (Typ)); + Type_Level := Make_Integer_Literal (Loc, + Deepest_Type_Access_Level (Typ)); -- Raise Program_Error if the accessibility level of the access -- parameter is deeper than the level of the target access type. diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 753dd4bfc91..3f12cedefb3 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -1038,7 +1038,8 @@ package body Einfo is function Extra_Accessibility (Id : E) return E is begin - pragma Assert (Is_Formal (Id) or else Ekind (Id) = E_Variable); + pragma Assert + (Is_Formal (Id) or else Ekind_In (Id, E_Variable, E_Constant)); return Node13 (Id); end Extra_Accessibility; @@ -3506,7 +3507,8 @@ package body Einfo is procedure Set_Extra_Accessibility (Id : E; V : E) is begin - pragma Assert (Is_Formal (Id) or else Ekind (Id) = E_Variable); + pragma Assert + (Is_Formal (Id) or else Ekind_In (Id, E_Variable, E_Constant)); Set_Node13 (Id, V); end Set_Extra_Accessibility; @@ -5466,6 +5468,7 @@ package body Einfo is procedure Init_Size (Id : E; V : Int) is begin Set_Uint12 (Id, UI_From_Int (V)); -- Esize + pragma Assert (not Is_Object (Id)); Set_Uint13 (Id, UI_From_Int (V)); -- RM_Size end Init_Size; @@ -5476,10 +5479,21 @@ package body Einfo is procedure Init_Size_Align (Id : E) is begin Set_Uint12 (Id, Uint_0); -- Esize + pragma Assert (not Is_Object (Id)); Set_Uint13 (Id, Uint_0); -- RM_Size Set_Uint14 (Id, Uint_0); -- Alignment end Init_Size_Align; + ---------------------------- + -- Init_Object_Size_Align -- + ---------------------------- + + procedure Init_Object_Size_Align (Id : E) is + begin + Set_Uint12 (Id, Uint_0); -- Esize + Set_Uint14 (Id, Uint_0); -- Alignment + end Init_Object_Size_Align; + ---------------------------------------------- -- Type Representation Attribute Predicates -- ---------------------------------------------- diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index c60fdd1aeb0..41ab2675af6 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2446,10 +2446,11 @@ package Einfo is -- Is_Local_Anonymous_Access (Flag194) -- Present in access types. Set for an anonymous access type to indicate -- that the type is created for a record component with an access --- definition, an array component, or a stand-alone object. Such --- anonymous types have an accessibility level equal to that of the +-- definition, an array component, or (pre-Ada2012) a stand-alone object. +-- Such anonymous types have an accessibility level equal to that of the -- declaration in which they appear, unlike the anonymous access types --- that are created for access parameters and access discriminants. +-- that are created for access parameters, access discriminants, and +-- (as of Ada2012) stand-alone objects. -- Is_Machine_Code_Subprogram (Flag137) -- Present in subprogram entities. Set to indicate that the subprogram @@ -5050,6 +5051,7 @@ package Einfo is -- Discriminal_Link (Node10) (discriminals only) -- Full_View (Node11) -- Esize (Uint12) + -- Extra_Accessibility (Node13) (constants only) -- Alignment (Uint14) -- Return_Flag_Or_Transient_Decl (Node15) (constants only) -- Actual_Subtype (Node17) @@ -7017,6 +7019,10 @@ package Einfo is -- This procedure initializes both size fields and the alignment -- field to all be Unknown. + procedure Init_Object_Size_Align (Id : E); + -- Same as Init_Size_Align except RM_Size field (which is only for types) + -- is unaffected. + procedure Init_Size (Id : E; V : Int); -- Initialize both the Esize and RM_Size fields of E to V diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 361b2a4797f..3f11e0efcd5 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -5261,6 +5261,47 @@ package body Exp_Ch3 is end if; end if; + if Nkind (N) = N_Object_Declaration + and then Nkind (Object_Definition (N)) = N_Access_Definition + and then not Is_Local_Anonymous_Access (Etype (Def_Id)) + then + -- An Ada 2012 stand-alone object of an anonymous access type + + declare + Loc : constant Source_Ptr := Sloc (N); + + Level : constant Entity_Id := + Make_Defining_Identifier (Sloc (N), + Chars => New_External_Name (Chars (Def_Id), + Suffix => "L")); + Level_Expr : Node_Id; + Level_Decl : Node_Id; + begin + Set_Ekind (Level, Ekind (Def_Id)); + Set_Etype (Level, Standard_Natural); + Set_Scope (Level, Scope (Def_Id)); + + if No (Expr) then + Level_Expr := Make_Integer_Literal (Loc, + -- accessibility level of null + Intval => Scope_Depth (Standard_Standard)); + else + Level_Expr := Dynamic_Accessibility_Level (Expr); + end if; + + Level_Decl := Make_Object_Declaration (Loc, + Defining_Identifier => Level, + Object_Definition => New_Occurrence_Of (Standard_Natural, Loc), + Expression => Level_Expr, + Constant_Present => Constant_Present (N), + Has_Init_Expression => True); + + Insert_Action_After (Init_After, Level_Decl); + + Set_Extra_Accessibility (Def_Id, Level); + end; + end if; + -- Exception on library entity not available exception diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index e21d9d1d791..b7698abe279 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -4996,14 +4996,15 @@ package body Exp_Ch4 is else if Present (Expr_Entity) - and then Present (Extra_Accessibility (Expr_Entity)) + and then Present + (Effective_Extra_Accessibility (Expr_Entity)) and then UI_Gt (Object_Access_Level (Lop), Type_Access_Level (Rtyp)) then Param_Level := New_Occurrence_Of - (Extra_Accessibility (Expr_Entity), Loc); + (Effective_Extra_Accessibility (Expr_Entity), Loc); Type_Level := Make_Integer_Literal (Loc, Type_Access_Level (Rtyp)); @@ -8279,6 +8280,10 @@ package body Exp_Ch4 is procedure Real_Range_Check; -- Handles generation of range check for real target value + function Has_Extra_Accessibility (Id : Entity_Id) return Boolean; + -- True iff Present (Effective_Extra_Accessibility (Id)) successfully + -- evaluates to True. + ----------------------------------- -- Handle_Changed_Representation -- ----------------------------------- @@ -8578,6 +8583,22 @@ package body Exp_Ch4 is Analyze_And_Resolve (N, Btyp); end Real_Range_Check; + ----------------------------- + -- Has_Extra_Accessibility -- + ----------------------------- + + -- Returns true for a formal of an anonymous access type or for + -- an Ada 2012-style stand-alone object of an anonymous access type. + + function Has_Extra_Accessibility (Id : Entity_Id) return Boolean is + begin + if Is_Formal (Id) or else Ekind_In (Id, E_Constant, E_Variable) then + return Present (Effective_Extra_Accessibility (Id)); + else + return False; + end if; + end Has_Extra_Accessibility; + -- Start of processing for Expand_N_Type_Conversion begin @@ -8736,13 +8757,7 @@ package body Exp_Ch4 is -- as tagged type checks). if Is_Entity_Name (Operand) - and then - (Is_Formal (Entity (Operand)) - or else - (Present (Renamed_Object (Entity (Operand))) - and then Is_Entity_Name (Renamed_Object (Entity (Operand))) - and then Is_Formal - (Entity (Renamed_Object (Entity (Operand)))))) + and then Has_Extra_Accessibility (Entity (Operand)) and then Ekind (Etype (Operand)) = E_Anonymous_Access_Type and then (Nkind (Original_Node (N)) /= N_Attribute_Reference or else Attribute_Name (Original_Node (N)) = Name_Access) diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 366140e9580..aa0879b465e 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -1885,6 +1885,57 @@ package body Exp_Ch5 is Apply_Constraint_Check (Rhs, Etype (Lhs)); end if; + -- Ada 2012 (AI05-148): Update current accessibility level if + -- Rhs is a stand-alone obj of an anonymous access type. + + if Is_Access_Type (Typ) + and then Is_Entity_Name (Lhs) + and then Present (Effective_Extra_Accessibility (Entity (Lhs))) then + declare + function Lhs_Entity return Entity_Id; + -- Look through renames to find the underlying entity. + -- For assignment to a rename, we don't care about the + -- Enclosing_Dynamic_Scope of the rename declaration. + + ---------------- + -- Lhs_Entity -- + ---------------- + + function Lhs_Entity return Entity_Id is + Result : Entity_Id := Entity (Lhs); + begin + while Present (Renamed_Object (Result)) loop + -- Renamed_Object must return an Entity_Name here + -- because of preceding "Present (E_E_A (...))" test. + + Result := Entity (Renamed_Object (Result)); + end loop; + return Result; + end Lhs_Entity; + + Access_Check : constant Node_Id := + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Gt (Loc, + Left_Opnd => Dynamic_Accessibility_Level (Rhs), + Right_Opnd => + Make_Integer_Literal (Loc, + Scope_Depth (Enclosing_Dynamic_Scope (Lhs_Entity)))), + Reason => PE_Accessibility_Check_Failed); + + Access_Level_Update : constant Node_Id := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of ( + Effective_Extra_Accessibility (Entity (Lhs)), Loc), + Expression => Dynamic_Accessibility_Level (Rhs)); + begin + if not Accessibility_Checks_Suppressed (Entity (Lhs)) then + Insert_Action (N, Access_Check); + end if; + Insert_Action (N, Access_Level_Update); + end; + end if; + -- Case of assignment to a bit packed array element. If there is a -- change of representation this must be expanded into components, -- otherwise this is a bit-field assignment. diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 93d8174ea6e..b3bd10a9230 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -1201,10 +1201,46 @@ package body Exp_Ch6 is Set_Assignment_OK (Lhs); - Append_To (Post_Call, - Make_Assignment_Statement (Loc, - Name => Lhs, - Expression => Expr)); + if Is_Access_Type (E_Formal) + and then Is_Entity_Name (Lhs) + and then Present (Effective_Extra_Accessibility + (Entity (Lhs))) + then + -- Copyback target is an Ada 2012 stand-alone object + -- of an anonymous access type + + pragma Assert (Ada_Version >= Ada_2012); + + if Type_Access_Level (E_Formal) > + Object_Access_Level (Lhs) then + Append_To (Post_Call, Make_Raise_Program_Error (Loc, + Reason => PE_Accessibility_Check_Failed)); + end if; + + Append_To (Post_Call, + Make_Assignment_Statement (Loc, + Name => Lhs, + Expression => Expr)); + + -- We would like to somehow suppress generation of + -- the extra_accessibility assignment generated by + -- the expansion of the above assignment statement. + -- It's not a correctness issue because the following + -- assignment renders it dead, but generating back-to-back + -- assignments to the same target is undesirable. ??? + + Append_To (Post_Call, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of ( + Effective_Extra_Accessibility (Entity (Lhs)), Loc), + Expression => Make_Integer_Literal (Loc, + Type_Access_Level (E_Formal)))); + else + Append_To (Post_Call, + Make_Assignment_Statement (Loc, + Name => Lhs, + Expression => Expr)); + end if; end; end if; end Add_Call_By_Copy_Code; @@ -2406,8 +2442,7 @@ package body Exp_Ch6 is else Add_Extra_Actual - (Make_Integer_Literal (Loc, - Intval => Type_Access_Level (Etype (Prev_Orig))), + (Dynamic_Accessibility_Level (Prev_Orig), Extra_Accessibility (Formal)); end if; @@ -2497,15 +2532,15 @@ package body Exp_Ch6 is Intval => Scope_Depth (Current_Scope) + 1), Extra_Accessibility (Formal)); - -- For other cases we simply pass the level of the actual's - -- access type. The type is retrieved from Prev rather than - -- Prev_Orig, because in some cases Prev_Orig denotes an - -- original expression that has not been analyzed. + -- For most other cases we simply pass the level of the + -- actual's access type. The type is retrieved from + -- Prev rather than Prev_Orig, because in some cases + -- Prev_Orig denotes an original expression that has + -- not been analyzed. when others => Add_Extra_Actual - (Make_Integer_Literal (Loc, - Intval => Type_Access_Level (Etype (Prev))), + (Dynamic_Accessibility_Level (Prev), Extra_Accessibility (Formal)); end case; end if; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 3adbac5cdb0..66ff686ed1f 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -8312,8 +8312,16 @@ package body Sem_Attr is -- the level is the same of the enclosing composite type. if Ada_Version >= Ada_2005 - and then Is_Local_Anonymous_Access (Btyp) - and then Object_Access_Level (P) > Type_Access_Level (Btyp) + and then (Is_Local_Anonymous_Access (Btyp) + + -- Handle cases where Btyp is the + -- anonymous access type of an Ada 2012 + -- stand-alone object. + + or else Nkind (Associated_Node_For_Itype + (Btyp)) = N_Object_Declaration) + and then Object_Access_Level (P) + > Deepest_Type_Access_Level (Btyp) and then Attr_Id = Attribute_Access then -- In an instance, this is a runtime check, but one we diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index d21e8a1a8d5..9babd7ce3d4 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -15122,7 +15122,10 @@ package body Sem_Ch3 is elsif Def_Kind = N_Access_Definition then T := Access_Definition (Related_Nod, Obj_Def); - Set_Is_Local_Anonymous_Access (T); + + Set_Is_Local_Anonymous_Access (T, V => (Ada_Version < Ada_2012) + or else (Nkind (P) /= N_Object_Declaration) + or else Is_Library_Level_Entity (Defining_Identifier (P))); -- Otherwise, the object definition is just a subtype_mark diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 7de014fefe9..6b9e256a6c8 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -601,6 +601,14 @@ package body Sem_Ch5 is then if Is_Local_Anonymous_Access (T1) or else Ekind (T2) = E_Anonymous_Access_Subprogram_Type + + -- Handle assignment to an Ada 2012 stand-alone object + -- of an anonymous access type. + + or else (Ekind (T1) = E_Anonymous_Access_Type + and then Nkind (Associated_Node_For_Itype (T1)) + = N_Object_Declaration) + then Rewrite (Rhs, Convert_To (T1, Relocate_Node (Rhs))); Analyze_And_Resolve (Rhs, T1); diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 662a0e9bb5d..47dcbc4b813 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -1137,7 +1137,7 @@ package body Sem_Ch8 is end if; Set_Ekind (Id, E_Variable); - Init_Size_Align (Id); + Init_Object_Size_Align (Id); if T = Any_Type or else Etype (Nam) = Any_Type then return; diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 66fcb07e0ab..067d1cfdcc0 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -850,9 +850,12 @@ package body Sem_Disp is Typ := Etype (Subp); end if; - if not Is_Class_Wide_Type (Typ) + if Comes_From_Source (Subp) and then Is_Interface (Typ) + and then not Is_Class_Wide_Type (Typ) and then not Is_Derived_Type (Typ) + and then not Is_Generic_Type (Typ) + and then not In_Instance then Error_Msg_N ("?declaration of& is too late!", Subp); Error_Msg_NE diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 0d03b298c6f..cf395f90901 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -10530,8 +10530,9 @@ package body Sem_Res is if Ekind (Target_Type) /= E_Anonymous_Access_Type then if Type_Access_Level (Opnd_Type) > - Type_Access_Level (Target_Type) + Deepest_Type_Access_Level (Target_Type) then + -- In an instance, this is a run-time check, but one we know -- will fail, so generate an appropriate warning. The raise -- will be generated by Expand_N_Type_Conversion. @@ -10562,7 +10563,7 @@ package body Sem_Res is if Nkind (Operand) = N_Selected_Component and then Object_Access_Level (Operand) > - Type_Access_Level (Target_Type) + Deepest_Type_Access_Level (Target_Type) then -- In an instance, this is a run-time check, but one we know -- will fail, so generate an appropriate warning. The raise @@ -10630,6 +10631,8 @@ package body Sem_Res is if Ekind (Target_Type) /= E_Anonymous_Access_Type or else Is_Local_Anonymous_Access (Target_Type) + or else Nkind (Associated_Node_For_Itype (Target_Type)) = + N_Object_Declaration then -- Ada 2012 (AI05-0149): Perform legality checking on implicit -- conversions from an anonymous access type to a named general @@ -10687,8 +10690,8 @@ package body Sem_Res is -- statically less deep than that of the target type, else -- implicit conversion is disallowed (by RM12-8.6(27.1/3)). - elsif Type_Access_Level (Opnd_Type) - > Type_Access_Level (Target_Type) + elsif Type_Access_Level (Opnd_Type) > + Deepest_Type_Access_Level (Target_Type) then Error_Msg_N ("implicit conversion of anonymous access value " & @@ -10697,8 +10700,8 @@ package body Sem_Res is end if; end if; - elsif Type_Access_Level (Opnd_Type) - > Type_Access_Level (Target_Type) + elsif Type_Access_Level (Opnd_Type) > + Deepest_Type_Access_Level (Target_Type) then -- In an instance, this is a run-time check, but one we know @@ -10737,7 +10740,7 @@ package body Sem_Res is if Nkind (Operand) = N_Selected_Component and then Object_Access_Level (Operand) > - Type_Access_Level (Target_Type) + Deepest_Type_Access_Level (Target_Type) then -- In an instance, this is a run-time check, but one we know -- will fail, so generate an appropriate warning. The raise @@ -10909,7 +10912,7 @@ package body Sem_Res is -- Check the static accessibility rule of 4.6(20) if Type_Access_Level (Opnd_Type) > - Type_Access_Level (Target_Type) + Deepest_Type_Access_Level (Target_Type) then Error_Msg_N ("operand type has deeper accessibility level than target", diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 6a5e5f1a1fd..bb2c07d9237 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -2372,6 +2372,26 @@ package body Sem_Util is end if; end Current_Subprogram; + ---------------------------------- + -- Deepest_Type_Access_Level -- + ---------------------------------- + + function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint is + begin + if Ekind (Typ) = E_Anonymous_Access_Type + and then not Is_Local_Anonymous_Access (Typ) + and then Nkind (Associated_Node_For_Itype (Typ)) = N_Object_Declaration + then + -- Typ is the type of an Ada 2012 stand-alone object of an + -- anonymous access type. + + return Scope_Depth (Enclosing_Dynamic_Scope (Defining_Identifier ( + Associated_Node_For_Itype (Typ)))); + else + return Type_Access_Level (Typ); + end if; + end Deepest_Type_Access_Level; + --------------------- -- Defining_Entity -- --------------------- @@ -2848,6 +2868,99 @@ package body Sem_Util is end if; end Designate_Same_Unit; + ------------------------------------------ + -- function Dynamic_Accessibility_Level -- + ------------------------------------------ + + function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id is + E : Entity_Id; + Loc : constant Source_Ptr := Sloc (Expr); + begin + if Is_Entity_Name (Expr) then + E := Entity (Expr); + + if Present (Renamed_Object (E)) then + return Dynamic_Accessibility_Level (Renamed_Object (E)); + end if; + + if Is_Formal (E) or else Ekind_In (E, E_Variable, E_Constant) then + if Present (Extra_Accessibility (E)) then + return New_Occurrence_Of (Extra_Accessibility (E), Loc); + end if; + end if; + end if; + + -- unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ??? + + case Nkind (Expr) is + -- for access discriminant, the level of the enclosing object + + when N_Selected_Component => + if Ekind (Entity (Selector_Name (Expr))) = E_Discriminant + and then Ekind (Etype (Entity (Selector_Name (Expr)))) = + E_Anonymous_Access_Type then + + return Make_Integer_Literal (Loc, Object_Access_Level (Expr)); + end if; + + when N_Attribute_Reference => + case Get_Attribute_Id (Attribute_Name (Expr)) is + + -- For X'Access, the level of the prefix X + + when Attribute_Access => + return Make_Integer_Literal (Loc, + Object_Access_Level (Prefix (Expr))); + + -- Treat the unchecked attributes as library-level + + when Attribute_Unchecked_Access | + Attribute_Unrestricted_Access => + return Make_Integer_Literal (Loc, + Scope_Depth (Standard_Standard)); + + -- No other access-valued attributes + + when others => + raise Program_Error; + end case; + + when N_Allocator => + -- Unimplemented: depends on context. As an actual + -- parameter where formal type is anonymous, use + -- Scope_Depth (Current_Scope) + 1. + -- For other cases, see 3.10.2(14/3) and following. ??? + null; + + when N_Type_Conversion => + if not Is_Local_Anonymous_Access (Etype (Expr)) then + -- Handle type conversions introduced for a + -- rename of an Ada2012 stand-alone object of an + -- anonymous access type. + return Dynamic_Accessibility_Level (Expression (Expr)); + end if; + + when others => + null; + end case; + + return Make_Integer_Literal (Loc, Type_Access_Level (Etype (Expr))); + end Dynamic_Accessibility_Level; + + ----------------------------------- + -- Effective_Extra_Accessibility -- + ----------------------------------- + + function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id is + begin + if Present (Renamed_Object (Id)) + and then Is_Entity_Name (Renamed_Object (Id)) then + return Effective_Extra_Accessibility (Entity (Renamed_Object (Id))); + end if; + + return Extra_Accessibility (Id); + end Effective_Extra_Accessibility; + -------------------------- -- Enclosing_CPP_Parent -- -------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index b3844d89608..2b7a93286b9 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -292,6 +292,15 @@ package Sem_Util is -- Current_Scope is returned. The returned value is Empty if this is called -- from a library package which is not within any subprogram. + function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint; + -- Same as Type_Access_Level, except that if the + -- type is the type of an Ada 2012 stand-alone object of an + -- anonymous access type, then return the static accesssibility level + -- of the object. In that case, the dynamic accessibility level + -- of the object may take on values in a range. The low bound of + -- of that range is returned by Type_Access_Level; this + -- function yields the high bound of that range. + function Defining_Entity (N : Node_Id) return Entity_Id; -- Given a declaration N, returns the associated defining entity. If the -- declaration has a specification, the entity is obtained from the @@ -332,6 +341,16 @@ package Sem_Util is -- these names is supposed to be a selected component name, an expanded -- name, a defining program unit name or an identifier. + function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id; + -- Expr should be an expression of an access type. + -- Builds an integer literal except in cases involving anonymous + -- access types where accessibility levels are tracked at runtime + -- (access parameters and Ada 2012 stand-alone objects). + + function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id; + -- Same as Einfo.Extra_Accessibility except thtat object renames + -- are looked through. + function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id; -- Returns the closest ancestor of Typ that is a CPP type. |