-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- If this is first subtype, or is a base type, then there is no
-- ancestor subtype, so we return Empty to indicate this fact.
- if Is_First_Subtype (Typ) or else Typ = Base_Type (Typ) then
+ if Is_First_Subtype (Typ) or else Is_Base_Type (Typ) then
return Empty;
end if;
Full_D : Node_Id;
begin
- -- If we have no declaration node, then return no constant value.
- -- Not clear how this can happen, but it does sometimes and this is
- -- the safest approach.
+ -- If we have no declaration node, then return no constant value. Not
+ -- clear how this can happen, but it does sometimes and this is the
+ -- safest approach.
if No (D) then
return Empty;
elsif Nkind (D) = N_Object_Renaming_Declaration then
return Renamed_Object (Ent);
- -- If this is a component declaration whose entity is constant, it
- -- is a prival within a protected function. It does not have
- -- a constant value.
+ -- If this is a component declaration whose entity is a constant, it is
+ -- a prival within a protected function (and so has no constant value).
elsif Nkind (D) = N_Component_Declaration then
return Empty;
-----------------------------
function Enclosing_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
- S : Entity_Id;
+ S : Entity_Id;
begin
- -- The following test is an error defense against some syntax
- -- errors that can leave scopes very messed up.
+ -- The following test is an error defense against some syntax errors
+ -- that can leave scopes very messed up.
if Ent = Standard_Standard then
return Ent;
-- Normal case, search enclosing scopes
- -- Note: the test for Present (S) should not be required, it is a
- -- defence against an ill-formed tree.
+ -- Note: the test for Present (S) should not be required, it defends
+ -- against an ill-formed tree.
S := Scope (Ent);
loop
if No (S) then
return Standard_Standard;
- -- Quit if we get to standard or a dynamic scope
+ -- Quit if we get to standard or a dynamic scope. We must also
+ -- handle enclosing scopes that have a full view; required to
+ -- locate enclosing scopes that are synchronized private types
+ -- whose full view is a task type.
elsif S = Standard_Standard
or else Is_Dynamic_Scope (S)
+ or else (Is_Private_Type (S)
+ and then Present (Full_View (S))
+ and then Is_Dynamic_Scope (Full_View (S)))
then
return S;
begin
pragma Assert
- (Has_Discriminants (Typ)
- or else Has_Unknown_Discriminants (Typ));
+ (Has_Discriminants (Typ) or else Has_Unknown_Discriminants (Typ));
Ent := First_Entity (Typ);
-- The discriminants are not necessarily contiguous, because access
-- discriminants will generate itypes. They are not the first entities
- -- either, because tag and controller record must be ahead of them.
+ -- either because the tag must be ahead of them.
if Chars (Ent) = Name_uTag then
Ent := Next_Entity (Ent);
end if;
- if Chars (Ent) = Name_uController then
- Ent := Next_Entity (Ent);
- end if;
-
-- Skip all hidden stored discriminants if any
while Present (Ent) loop
Ent := Next_Entity (Ent);
end if;
- if Chars (Ent) = Name_uController then
- Ent := Next_Entity (Ent);
- end if;
-
if Has_Completely_Hidden_Discriminant (Ent) then
-
while Present (Ent) loop
exit when Is_Completely_Hidden (Ent);
Ent := Next_Entity (Ent);
end loop;
-
end if;
pragma Assert (Ekind (Ent) = E_Discriminant);
Ent : Entity_Id;
begin
- -- If the base type has no freeze node, it is a type in standard,
- -- and always acts as its own first subtype unless it is one of
- -- the predefined integer types. If the type is formal, it is also
- -- a first subtype, and its base type has no freeze node. On the other
- -- hand, a subtype of a generic formal is not its own first_subtype.
- -- Its base type, if anonymous, is attached to the formal type decl.
- -- from which the first subtype is obtained.
+ -- If the base type has no freeze node, it is a type in Standard, and
+ -- always acts as its own first subtype, except where it is one of the
+ -- predefined integer types. If the type is formal, it is also a first
+ -- subtype, and its base type has no freeze node. On the other hand, a
+ -- subtype of a generic formal is not its own first subtype. Its base
+ -- type, if anonymous, is attached to the formal type decl. from which
+ -- the first subtype is obtained.
if No (F) then
-
if B = Base_Type (Standard_Integer) then
return Standard_Integer;
return Empty;
end First_Tag_Component;
+ -------------------------------
+ -- Initialization_Suppressed --
+ -------------------------------
+
+ function Initialization_Suppressed (Typ : Entity_Id) return Boolean is
+ begin
+ return Suppress_Initialization (Typ)
+ or else Suppress_Initialization (Base_Type (Typ));
+ end Initialization_Suppressed;
+
----------------
-- Initialize --
----------------
Btype : constant Entity_Id := Base_Type (Ent);
begin
- if Error_Posted (Ent)
- or else Error_Posted (Btype)
- then
+ if Error_Posted (Ent) or else Error_Posted (Btype) then
return False;
elsif Is_Private_Type (Btype) then
end if;
end Is_Derived_Type;
+ -----------------------
+ -- Is_Generic_Formal --
+ -----------------------
+
+ function Is_Generic_Formal (E : Entity_Id) return Boolean is
+ Kind : Node_Kind;
+ begin
+ if No (E) then
+ return False;
+ else
+ Kind := Nkind (Parent (E));
+ return
+ Nkind_In (Kind, N_Formal_Object_Declaration,
+ N_Formal_Package_Declaration,
+ N_Formal_Type_Declaration)
+ or else Is_Formal_Subprogram (E);
+ end if;
+ end Is_Generic_Formal;
+
---------------------------
-- Is_Indefinite_Subtype --
---------------------------
end if;
end Is_Indefinite_Subtype;
- --------------------------------
- -- Is_Inherently_Limited_Type --
- --------------------------------
+ -------------------------------
+ -- Is_Immutably_Limited_Type --
+ -------------------------------
- function Is_Inherently_Limited_Type (Ent : Entity_Id) return Boolean is
- Btype : constant Entity_Id := Base_Type (Ent);
+ function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is
+ Btype : constant Entity_Id := Available_View (Base_Type (Ent));
begin
- if Is_Private_Type (Btype) then
- declare
- Utyp : constant Entity_Id := Underlying_Type (Btype);
- begin
- if No (Utyp) then
+ if Is_Limited_Record (Btype) then
+ return True;
+
+ elsif Ekind (Btype) = E_Limited_Private_Type
+ and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration
+ then
+ return not In_Package_Body (Scope ((Btype)));
+
+ elsif Is_Private_Type (Btype) then
+
+ -- AI05-0063: A type derived from a limited private formal type is
+ -- not immutably limited in a generic body.
+
+ if Is_Derived_Type (Btype)
+ and then Is_Generic_Type (Etype (Btype))
+ then
+ if not Is_Limited_Type (Etype (Btype)) then
return False;
+
+ -- A descendant of a limited formal type is not immutably limited
+ -- in the generic body, or in the body of a generic child.
+
+ elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then
+ return not In_Package_Body (Scope (Btype));
+
else
- return Is_Inherently_Limited_Type (Utyp);
+ return False;
end if;
- end;
+
+ else
+ declare
+ Utyp : constant Entity_Id := Underlying_Type (Btype);
+ begin
+ if No (Utyp) then
+ return False;
+ else
+ return Is_Immutably_Limited_Type (Utyp);
+ end if;
+ end;
+ end if;
elsif Is_Concurrent_Type (Btype) then
return True;
elsif Is_Record_Type (Btype) then
- if Is_Limited_Record (Btype) then
- return not Is_Interface (Btype)
- or else Is_Protected_Interface (Btype)
- or else Is_Synchronized_Interface (Btype)
- or else Is_Task_Interface (Btype);
- elsif Is_Class_Wide_Type (Btype) then
- return Is_Inherently_Limited_Type (Root_Type (Btype));
+ -- Note that we return True for all limited interfaces, even though
+ -- (unsynchronized) limited interfaces can have descendants that are
+ -- nonlimited, because this is a predicate on the type itself, and
+ -- things like functions with limited interface results need to be
+ -- handled as build in place even though they might return objects
+ -- of a type that is not inherently limited.
+
+ if Is_Class_Wide_Type (Btype) then
+ return Is_Immutably_Limited_Type (Root_Type (Btype));
else
declare
begin
C := First_Component (Btype);
while Present (C) loop
- if Is_Inherently_Limited_Type (Etype (C)) then
+
+ -- Don't consider components with interface types (which can
+ -- only occur in the case of a _parent component anyway).
+ -- They don't have any components, plus it would cause this
+ -- function to return true for nonlimited types derived from
+ -- limited interfaces.
+
+ if not Is_Interface (Etype (C))
+ and then Is_Immutably_Limited_Type (Etype (C))
+ then
return True;
end if;
end if;
elsif Is_Array_Type (Btype) then
- return Is_Inherently_Limited_Type (Component_Type (Btype));
+ return Is_Immutably_Limited_Type (Component_Type (Btype));
else
return False;
end if;
- end Is_Inherently_Limited_Type;
+ end Is_Immutably_Limited_Type;
---------------------
-- Is_Limited_Type --
end if;
end Is_Limited_Type;
+ ----------------------
+ -- Nearest_Ancestor --
+ ----------------------
+
+ function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id is
+ D : constant Node_Id := Declaration_Node (Typ);
+
+ begin
+ -- If we have a subtype declaration, get the ancestor subtype
+
+ if Nkind (D) = N_Subtype_Declaration then
+ if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then
+ return Entity (Subtype_Mark (Subtype_Indication (D)));
+ else
+ return Entity (Subtype_Indication (D));
+ end if;
+
+ -- If derived type declaration, find who we are derived from
+
+ elsif Nkind (D) = N_Full_Type_Declaration
+ and then Nkind (Type_Definition (D)) = N_Derived_Type_Definition
+ then
+ declare
+ DTD : constant Entity_Id := Type_Definition (D);
+ SI : constant Entity_Id := Subtype_Indication (DTD);
+ begin
+ if Is_Entity_Name (SI) then
+ return Entity (SI);
+ else
+ return Entity (Subtype_Mark (SI));
+ end if;
+ end;
+
+ -- Otherwise, nothing useful to return, return Empty
+
+ else
+ return Empty;
+ end if;
+ end Nearest_Ancestor;
+
+ ---------------------------
+ -- Nearest_Dynamic_Scope --
+ ---------------------------
+
+ function Nearest_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
+ begin
+ if Is_Dynamic_Scope (Ent) then
+ return Ent;
+ else
+ return Enclosing_Dynamic_Scope (Ent);
+ end if;
+ end Nearest_Dynamic_Scope;
+
------------------------
-- Next_Tag_Component --
------------------------
begin
pragma Assert (Is_Tag (Tag));
+ -- Loop to look for next tag component
+
Comp := Next_Entity (Tag);
while Present (Comp) loop
if Is_Tag (Comp) then
Obsolescent_Warnings.Tree_Write;
end Tree_Write;
+ --------------------
+ -- Ultimate_Alias --
+ --------------------
+
+ function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is
+ E : Entity_Id := Prim;
+
+ begin
+ while Present (Alias (E)) loop
+ pragma Assert (Alias (E) /= E);
+ E := Alias (E);
+ end loop;
+
+ return E;
+ end Ultimate_Alias;
+
end Sem_Aux;
OSDN Git Service
