mirror of git://gcc.gnu.org/git/gcc.git
[multiple changes]
2015-05-28 Ed Schonberg <schonberg@adacore.com> * 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 <duff@adacore.com> * 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. From-SVN: r223817
This commit is contained in:
parent
e65757f359
commit
228722248f
|
|
@ -1,3 +1,19 @@
|
||||||
|
2015-05-28 Ed Schonberg <schonberg@adacore.com>
|
||||||
|
|
||||||
|
* 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 <duff@adacore.com>
|
||||||
|
|
||||||
|
* 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 <duff@adacore.com>
|
2015-05-28 Bob Duff <duff@adacore.com>
|
||||||
|
|
||||||
* sem_util.adb (Requires_Transient_Scope): Avoid returning
|
* sem_util.adb (Requires_Transient_Scope): Avoid returning
|
||||||
|
|
|
||||||
|
|
@ -17946,7 +17946,7 @@ package body Sem_Ch3 is
|
||||||
N : Node_Id := Empty) return Boolean
|
N : Node_Id := Empty) return Boolean
|
||||||
is
|
is
|
||||||
Original_Comp : Entity_Id := Empty;
|
Original_Comp : Entity_Id := Empty;
|
||||||
Original_Scope : Entity_Id;
|
Original_Type : Entity_Id;
|
||||||
Type_Scope : Entity_Id;
|
Type_Scope : Entity_Id;
|
||||||
|
|
||||||
function Is_Local_Type (Typ : Entity_Id) return Boolean;
|
function Is_Local_Type (Typ : Entity_Id) return Boolean;
|
||||||
|
|
@ -17990,13 +17990,13 @@ package body Sem_Ch3 is
|
||||||
return False;
|
return False;
|
||||||
|
|
||||||
else
|
else
|
||||||
Original_Scope := Scope (Original_Comp);
|
Original_Type := Scope (Original_Comp);
|
||||||
Type_Scope := Scope (Base_Type (Scope (C)));
|
Type_Scope := Scope (Base_Type (Scope (C)));
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
-- This test only concerns tagged types
|
-- This test only concerns tagged types
|
||||||
|
|
||||||
if not Is_Tagged_Type (Original_Scope) then
|
if not Is_Tagged_Type (Original_Type) then
|
||||||
return True;
|
return True;
|
||||||
|
|
||||||
-- If it is _Parent or _Tag, there is no visibility issue
|
-- 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
|
elsif Ekind (Original_Comp) = E_Discriminant
|
||||||
and then
|
and then
|
||||||
(not Has_Unknown_Discriminants (Original_Scope)
|
(not Has_Unknown_Discriminants (Original_Type)
|
||||||
or else (Present (N)
|
or else (Present (N)
|
||||||
and then Nkind (N) = N_Selected_Component
|
and then Nkind (N) = N_Selected_Component
|
||||||
and then Nkind (Prefix (N)) = N_Type_Conversion
|
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
|
-- visible. The latter suppression of visibility is needed for cases
|
||||||
-- that are tested in B730006.
|
-- that are tested in B730006.
|
||||||
|
|
||||||
elsif Is_Private_Type (Original_Scope)
|
elsif Is_Private_Type (Original_Type)
|
||||||
or else
|
or else
|
||||||
(not Is_Private_Descendant (Type_Scope)
|
(not Is_Private_Descendant (Type_Scope)
|
||||||
and then not In_Open_Scopes (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
|
then
|
||||||
-- If the type derives from an entity in a formal package, there
|
-- If the type derives from an entity in a formal package, there
|
||||||
-- are no additional visible components.
|
-- are no additional visible components.
|
||||||
|
|
@ -18062,7 +18062,7 @@ package body Sem_Ch3 is
|
||||||
else
|
else
|
||||||
return
|
return
|
||||||
Is_Child_Unit (Cunit_Entity (Current_Sem_Unit))
|
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);
|
and then Is_Local_Type (Type_Scope);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
|
@ -18085,9 +18085,22 @@ package body Sem_Ch3 is
|
||||||
|
|
||||||
begin
|
begin
|
||||||
loop
|
loop
|
||||||
if Ancestor = Original_Scope then
|
if Ancestor = Original_Type then
|
||||||
return True;
|
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
|
elsif Ancestor = Etype (Ancestor) then
|
||||||
|
|
||||||
|
-- No further ancestors to examine.
|
||||||
|
|
||||||
return False;
|
return False;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -17103,6 +17103,11 @@ package body Sem_Util is
|
||||||
-- could be nested inside some other record that is constrained by
|
-- could be nested inside some other record that is constrained by
|
||||||
-- nondiscriminants). That is, the recursive calls are too conservative.
|
-- 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
|
function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean is
|
||||||
pragma Assert (Typ = Underlying_Type (Typ));
|
pragma Assert (Typ = Underlying_Type (Typ));
|
||||||
|
|
||||||
|
|
@ -17150,7 +17155,49 @@ package body Sem_Util is
|
||||||
return True;
|
return True;
|
||||||
end Caller_Known_Size_Record;
|
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);
|
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
|
elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then
|
||||||
return not Is_Value_Type (Typ);
|
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
|
-- Untagged definite subtypes are known size. This includes all
|
||||||
-- elementary [sub]types. Tasks are known size even if they have
|
-- elementary [sub]types. Tasks are known size even if they have
|
||||||
-- discriminants.
|
-- discriminants.
|
||||||
|
|
||||||
elsif Is_Definite_Subtype (Typ) or else Is_Task_Type (Typ) then
|
elsif Is_Definite_Subtype (Typ) or else Is_Task_Type (Typ) then
|
||||||
if Is_Array_Type (Typ) -- ???Shouldn't be necessary
|
if Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then
|
||||||
and then New_Requires_Transient_Scope
|
if not Has_Discriminants (Typ) then
|
||||||
(Underlying_Type (Component_Type (Typ)))
|
if Has_Discrim_Dep_Array (Typ) then
|
||||||
then
|
return True; -- ???Shouldn't be necessary
|
||||||
return True;
|
end if;
|
||||||
|
end if;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
return False;
|
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
|
-- Unconstrained array
|
||||||
|
|
||||||
else
|
else
|
||||||
|
|
|
||||||
|
|
@ -823,7 +823,7 @@ package Sem_Util is
|
||||||
-- returned. Otherwise the Etype of the node is returned.
|
-- returned. Otherwise the Etype of the node is returned.
|
||||||
|
|
||||||
function Get_Body_From_Stub (N : Node_Id) return Node_Id;
|
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
|
function Get_Cursor_Type
|
||||||
(Aspect : Node_Id;
|
(Aspect : Node_Id;
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue