diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 7975d323f5d..5fc0dd342be 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,19 @@ +2015-05-28 Ed Schonberg + + * sem_ch3.adb (Is_Visible_Component): Component is visible + in a derived type if inherited through an ancestor that has a + partial view of the original type holding the component, if the + full view of that original type is in scope. + * sem_util.ads (Get_Body_From_Stub): Works for all kinds of stubs. + +2015-05-28 Bob Duff + + * sem_util.adb (Requires_Transient_Scope): For definite untagged + subtypes, we should never have to use the secondary stack. This moves + toward that goal. But there are still cases that don't work. + Here, we move the check for Is_Definite first, but add a + special-purpose check for Has_Discrim_Dep_Array. + 2015-05-28 Bob Duff * sem_util.adb (Requires_Transient_Scope): Avoid returning diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index df86250b286..f163b1581b2 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -17946,7 +17946,7 @@ package body Sem_Ch3 is N : Node_Id := Empty) return Boolean is Original_Comp : Entity_Id := Empty; - Original_Scope : Entity_Id; + Original_Type : Entity_Id; Type_Scope : Entity_Id; function Is_Local_Type (Typ : Entity_Id) return Boolean; @@ -17990,13 +17990,13 @@ package body Sem_Ch3 is return False; else - Original_Scope := Scope (Original_Comp); + Original_Type := Scope (Original_Comp); Type_Scope := Scope (Base_Type (Scope (C))); end if; -- This test only concerns tagged types - if not Is_Tagged_Type (Original_Scope) then + if not Is_Tagged_Type (Original_Type) then return True; -- If it is _Parent or _Tag, there is no visibility issue @@ -18010,7 +18010,7 @@ package body Sem_Ch3 is elsif Ekind (Original_Comp) = E_Discriminant and then - (not Has_Unknown_Discriminants (Original_Scope) + (not Has_Unknown_Discriminants (Original_Type) or else (Present (N) and then Nkind (N) = N_Selected_Component and then Nkind (Prefix (N)) = N_Type_Conversion @@ -18038,11 +18038,11 @@ package body Sem_Ch3 is -- visible. The latter suppression of visibility is needed for cases -- that are tested in B730006. - elsif Is_Private_Type (Original_Scope) + elsif Is_Private_Type (Original_Type) or else (not Is_Private_Descendant (Type_Scope) and then not In_Open_Scopes (Type_Scope) - and then Has_Private_Declaration (Original_Scope)) + and then Has_Private_Declaration (Original_Type)) then -- If the type derives from an entity in a formal package, there -- are no additional visible components. @@ -18062,7 +18062,7 @@ package body Sem_Ch3 is else return Is_Child_Unit (Cunit_Entity (Current_Sem_Unit)) - and then In_Open_Scopes (Scope (Original_Scope)) + and then In_Open_Scopes (Scope (Original_Type)) and then Is_Local_Type (Type_Scope); end if; @@ -18085,9 +18085,22 @@ package body Sem_Ch3 is begin loop - if Ancestor = Original_Scope then + if Ancestor = Original_Type then return True; + + -- The ancestor may have a partial view of the original + -- type, but if the full view is in scope, as in a child + -- body, the component is visible. + + elsif In_Private_Part (Scope (Original_Type)) + and then Full_View (Ancestor) = Original_Type + then + return True; + elsif Ancestor = Etype (Ancestor) then + + -- No further ancestors to examine. + return False; end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index ecead06b4f8..a29b286f717 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -17103,6 +17103,11 @@ package body Sem_Util is -- could be nested inside some other record that is constrained by -- nondiscriminants). That is, the recursive calls are too conservative. + function Has_Discrim_Dep_Array (Typ : Entity_Id) return Boolean; + -- True if we find certain discriminant-dependent array + -- subcomponents. This shouldn't be necessary, but without this check, + -- we crash in gimplify. ??? + function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean is pragma Assert (Typ = Underlying_Type (Typ)); @@ -17150,7 +17155,49 @@ package body Sem_Util is return True; end Caller_Known_Size_Record; - -- Local deeclarations + function Has_Discrim_Dep_Array (Typ : Entity_Id) return Boolean is + pragma Assert (Typ = Underlying_Type (Typ)); + + begin + if Is_Array_Type (Typ) then + return Size_Depends_On_Discriminant (Typ); + end if; + + if Is_Record_Type (Typ) + or else + Is_Protected_Type (Typ) + then + declare + Comp : Entity_Id := First_Entity (Typ); + + begin + while Present (Comp) loop + + -- Only look at E_Component entities. No need to look at + -- E_Discriminant entities, and we must ignore internal + -- subtypes generated for constrained components. + + if Ekind (Comp) = E_Component then + declare + Comp_Type : constant Entity_Id := + Underlying_Type (Etype (Comp)); + + begin + if Has_Discrim_Dep_Array (Comp_Type) then + return True; + end if; + end; + end if; + + Next_Entity (Comp); + end loop; + end; + end if; + + return False; + end Has_Discrim_Dep_Array; + + -- Local declarations Typ : constant Entity_Id := Underlying_Type (Id); @@ -17184,26 +17231,26 @@ package body Sem_Util is elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then return not Is_Value_Type (Typ); - -- Indefinite (discriminated) untagged record or protected type - - elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then - return not Caller_Known_Size_Record (Typ); - -- ???Should come after Is_Definite_Subtype below - -- Untagged definite subtypes are known size. This includes all -- elementary [sub]types. Tasks are known size even if they have -- discriminants. elsif Is_Definite_Subtype (Typ) or else Is_Task_Type (Typ) then - if Is_Array_Type (Typ) -- ???Shouldn't be necessary - and then New_Requires_Transient_Scope - (Underlying_Type (Component_Type (Typ))) - then - return True; + if Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then + if not Has_Discriminants (Typ) then + if Has_Discrim_Dep_Array (Typ) then + return True; -- ???Shouldn't be necessary + end if; + end if; end if; return False; + -- Indefinite (discriminated) untagged record or protected type + + elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then + return not Caller_Known_Size_Record (Typ); + -- Unconstrained array else diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 3d5debdfcce..650731746bf 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -823,7 +823,7 @@ package Sem_Util is -- returned. Otherwise the Etype of the node is returned. function Get_Body_From_Stub (N : Node_Id) return Node_Id; - -- Return the body node for a stub (subprogram or package) + -- Return the body node for a stub. function Get_Cursor_Type (Aspect : Node_Id;