diff options
Diffstat (limited to 'gcc/ada/sem_ch3.adb')
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 58 |
1 files changed, 54 insertions, 4 deletions
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 488e6dc98cc..5cc06e7d899 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -726,13 +726,33 @@ package body Sem_Ch3 is -- If the access definition is the return type of another access to -- function, scope is the current one, because it is the one of the - -- current type declaration. + -- current type declaration, except for the pathological case below. if Nkind_In (Related_Nod, N_Object_Declaration, N_Access_Function_Definition) then Anon_Scope := Current_Scope; + -- A pathological case: function returning access functions that + -- return access functions, etc. Each anonymous access type created + -- is in the enclosing scope of the outermost function. + + declare + Par : Node_Id; + + begin + Par := Related_Nod; + while Nkind_In (Par, N_Access_Function_Definition, + N_Access_Definition) + loop + Par := Parent (Par); + end loop; + + if Nkind (Par) = N_Function_Specification then + Anon_Scope := Scope (Defining_Entity (Par)); + end if; + end; + -- For the anonymous function result case, retrieve the scope of the -- function specification's associated entity rather than using the -- current scope. The current scope will be the function itself if the @@ -1876,7 +1896,9 @@ package body Sem_Ch3 is -- (Ada 2005: AI-230): Accessibility check for anonymous -- components - if Type_Access_Level (Etype (E)) > Type_Access_Level (T) then + if Type_Access_Level (Etype (E)) > + Deepest_Type_Access_Level (T) + then Error_Msg_N ("expression has deeper access level than component " & "(RM 3.10.2 (12.2))", E); @@ -2664,8 +2686,8 @@ package body Sem_Ch3 is -- Process expression, replacing error by integer zero, to avoid -- cascaded errors or aborts further along in the processing - -- Replace Error by integer zero, which seems least likely to - -- cause cascaded errors. + -- Replace Error by integer zero, which seems least likely to cause + -- cascaded errors. if E = Error then Rewrite (E, Make_Integer_Literal (Sloc (E), Uint_0)); @@ -4042,6 +4064,19 @@ package body Sem_Ch3 is T := Process_Subtype (Subtype_Indication (N), N, Id, 'P'); + -- Class-wide equivalent types of records with unknown discriminants + -- involve the generation of an itype which serves as the private view + -- of a constrained record subtype. In such cases the base type of the + -- current subtype we are processing is the private itype. Use the full + -- of the private itype when decorating various attributes. + + if Is_Itype (T) + and then Is_Private_Type (T) + and then Present (Full_View (T)) + then + T := Full_View (T); + end if; + -- Inherit common attributes Set_Is_Generic_Type (Id, Is_Generic_Type (Base_Type (T))); @@ -11764,6 +11799,11 @@ package body Sem_Ch3 is -- needed, since checks may cause duplication of the expressions -- which must not be reevaluated. + -- The forced evaluation removes side effects from expressions, + -- which should occur also in Alfa mode. Otherwise, we end up with + -- unexpected insertions of actions at places where this is not + -- supposed to occur, e.g. on default parameters of a call. + if Expander_Active then Force_Evaluation (Low_Bound (R)); Force_Evaluation (High_Bound (R)); @@ -18304,6 +18344,11 @@ package body Sem_Ch3 is -- if needed, before applying checks, since checks may cause -- duplication of the expression without forcing evaluation. + -- The forced evaluation removes side effects from expressions, + -- which should occur also in Alfa mode. Otherwise, we end up with + -- unexpected insertions of actions at places where this is not + -- supposed to occur, e.g. on default parameters of a call. + if Expander_Active then Force_Evaluation (Lo); Force_Evaluation (Hi); @@ -18414,6 +18459,11 @@ package body Sem_Ch3 is -- Case of other than an explicit N_Range node + -- The forced evaluation removes side effects from expressions, which + -- should occur also in Alfa mode. Otherwise, we end up with unexpected + -- insertions of actions at places where this is not supposed to occur, + -- e.g. on default parameters of a call. + elsif Expander_Active then Get_Index_Bounds (R, Lo, Hi); Force_Evaluation (Lo); |