+ ----------------------
+ -- Ancestor_Subtype --
+ ----------------------
+
+ function Ancestor_Subtype (Typ : Entity_Id) return Entity_Id is
+ begin
+ -- 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
+ return Empty;
+ end if;
+
+ declare
+ 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 not, then no subtype indication is available
+
+ else
+ return Empty;
+ end if;
+ end;
+ end Ancestor_Subtype;
+
+ --------------------
+ -- Available_View --
+ --------------------
+
+ function Available_View (Typ : Entity_Id) return Entity_Id is
+ begin
+ if Is_Incomplete_Type (Typ)
+ and then Present (Non_Limited_View (Typ))
+ then
+ -- The non-limited view may itself be an incomplete type, in which
+ -- case get its full view.
+
+ return Get_Full_View (Non_Limited_View (Typ));
+
+ elsif Is_Class_Wide_Type (Typ)
+ and then Is_Incomplete_Type (Etype (Typ))
+ and then Present (Non_Limited_View (Etype (Typ)))
+ then
+ return Class_Wide_Type (Non_Limited_View (Etype (Typ)));
+
+ else
+ return Typ;
+ end if;
+ end Available_View;
+
+ --------------------
+ -- Constant_Value --
+ --------------------
+
+ function Constant_Value (Ent : Entity_Id) return Node_Id is
+ D : constant Node_Id := Declaration_Node (Ent);
+ 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 No (D) then
+ return Empty;
+
+ -- Normal case where a declaration node is present
+
+ 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.
+
+ elsif Nkind (D) = N_Component_Declaration then
+ return Empty;
+
+ -- If there is an expression, return it
+
+ elsif Present (Expression (D)) then
+ return (Expression (D));
+
+ -- For a constant, see if we have a full view
+
+ elsif Ekind (Ent) = E_Constant
+ and then Present (Full_View (Ent))
+ then
+ Full_D := Parent (Full_View (Ent));
+
+ -- The full view may have been rewritten as an object renaming
+
+ if Nkind (Full_D) = N_Object_Renaming_Declaration then
+ return Name (Full_D);
+ else
+ return Expression (Full_D);
+ end if;
+
+ -- Otherwise we have no expression to return
+
+ else
+ return Empty;
+ end if;
+ end Constant_Value;
+
+ -----------------------------
+ -- Enclosing_Dynamic_Scope --
+ -----------------------------
+
+ function Enclosing_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
+ S : Entity_Id;
+
+ begin
+ -- 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;
+ end if;
+
+ -- Normal case, search enclosing scopes
+
+ -- Note: the test for Present (S) should not be required, it is a
+ -- defence against an ill-formed tree.
+
+ S := Scope (Ent);
+ loop
+ -- If we somehow got an empty value for Scope, the tree must be
+ -- malformed. Rather than blow up we return Standard in this case.
+
+ if No (S) then
+ return Standard_Standard;
+
+ -- Quit if we get to standard or a dynamic scope
+
+ elsif S = Standard_Standard
+ or else Is_Dynamic_Scope (S)
+ then
+ return S;
+
+ -- Otherwise keep climbing
+
+ else
+ S := Scope (S);
+ end if;
+ end loop;
+ end Enclosing_Dynamic_Scope;
+
+ ------------------------
+ -- First_Discriminant --
+ ------------------------
+
+ function First_Discriminant (Typ : Entity_Id) return Entity_Id is
+ Ent : Entity_Id;
+
+ begin
+ pragma Assert
+ (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.
+
+ 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
+ exit when Ekind (Ent) = E_Discriminant
+ and then not Is_Completely_Hidden (Ent);
+
+ Ent := Next_Entity (Ent);
+ end loop;
+
+ pragma Assert (Ekind (Ent) = E_Discriminant);
+
+ return Ent;
+ end First_Discriminant;
+
+ -------------------------------
+ -- First_Stored_Discriminant --
+ -------------------------------
+
+ function First_Stored_Discriminant (Typ : Entity_Id) return Entity_Id is
+ Ent : Entity_Id;
+
+ function Has_Completely_Hidden_Discriminant
+ (Typ : Entity_Id) return Boolean;
+ -- Scans the Discriminants to see whether any are Completely_Hidden
+ -- (the mechanism for describing non-specified stored discriminants)
+
+ ----------------------------------------
+ -- Has_Completely_Hidden_Discriminant --
+ ----------------------------------------
+
+ function Has_Completely_Hidden_Discriminant
+ (Typ : Entity_Id) return Boolean
+ is
+ Ent : Entity_Id;
+
+ begin
+ pragma Assert (Ekind (Typ) = E_Discriminant);
+
+ Ent := Typ;
+ while Present (Ent) and then Ekind (Ent) = E_Discriminant loop
+ if Is_Completely_Hidden (Ent) then
+ return True;
+ end if;
+
+ Ent := Next_Entity (Ent);
+ end loop;
+
+ return False;
+ end Has_Completely_Hidden_Discriminant;
+
+ -- Start of processing for First_Stored_Discriminant
+
+ begin
+ pragma Assert
+ (Has_Discriminants (Typ)
+ or else Has_Unknown_Discriminants (Typ));
+
+ Ent := First_Entity (Typ);
+
+ if Chars (Ent) = Name_uTag then
+ 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);
+
+ return Ent;
+ end First_Stored_Discriminant;
+
+ -------------------
+ -- First_Subtype --
+ -------------------
+
+ function First_Subtype (Typ : Entity_Id) return Entity_Id is
+ B : constant Entity_Id := Base_Type (Typ);
+ F : constant Node_Id := Freeze_Node (B);
+ 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 No (F) then
+
+ if B = Base_Type (Standard_Integer) then
+ return Standard_Integer;
+
+ elsif B = Base_Type (Standard_Long_Integer) then
+ return Standard_Long_Integer;
+
+ elsif B = Base_Type (Standard_Short_Short_Integer) then
+ return Standard_Short_Short_Integer;
+
+ elsif B = Base_Type (Standard_Short_Integer) then
+ return Standard_Short_Integer;
+
+ elsif B = Base_Type (Standard_Long_Long_Integer) then
+ return Standard_Long_Long_Integer;
+
+ elsif Is_Generic_Type (Typ) then
+ if Present (Parent (B)) then
+ return Defining_Identifier (Parent (B));
+ else
+ return Defining_Identifier (Associated_Node_For_Itype (B));
+ end if;
+
+ else
+ return B;
+ end if;
+
+ -- Otherwise we check the freeze node, if it has a First_Subtype_Link
+ -- then we use that link, otherwise (happens with some Itypes), we use
+ -- the base type itself.
+
+ else
+ Ent := First_Subtype_Link (F);
+
+ if Present (Ent) then
+ return Ent;
+ else
+ return B;
+ end if;
+ end if;
+ end First_Subtype;
+
+ -------------------------
+ -- First_Tag_Component --
+ -------------------------
+
+ function First_Tag_Component (Typ : Entity_Id) return Entity_Id is
+ Comp : Entity_Id;
+ Ctyp : Entity_Id;
+
+ begin
+ Ctyp := Typ;
+ pragma Assert (Is_Tagged_Type (Ctyp));
+
+ if Is_Class_Wide_Type (Ctyp) then
+ Ctyp := Root_Type (Ctyp);
+ end if;
+
+ if Is_Private_Type (Ctyp) then
+ Ctyp := Underlying_Type (Ctyp);
+
+ -- If the underlying type is missing then the source program has
+ -- errors and there is nothing else to do (the full-type declaration
+ -- associated with the private type declaration is missing).
+
+ if No (Ctyp) then
+ return Empty;
+ end if;
+ end if;
+
+ Comp := First_Entity (Ctyp);
+ while Present (Comp) loop
+ if Is_Tag (Comp) then
+ return Comp;
+ end if;
+
+ Comp := Next_Entity (Comp);
+ end loop;
+
+ -- No tag component found
+
+ return Empty;
+ end First_Tag_Component;
+