URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [tags/] [gnu-src/] [gcc-4.5.1/] [gcc-4.5.1-or32-1.0rc4/] [gcc/] [ada/] [sem_aux.adb] - Rev 799
Go to most recent revision | Compare with Previous | Blame | View Log
------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ A U X -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2009, 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- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING3. If not, go to -- -- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Einfo; use Einfo; with Namet; use Namet; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; package body Sem_Aux is ---------------------- -- 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 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; -- 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 defends -- 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; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Obsolescent_Warnings.Init; end Initialize; --------------------- -- Is_By_Copy_Type -- --------------------- function Is_By_Copy_Type (Ent : Entity_Id) return Boolean is begin -- If Id is a private type whose full declaration has not been seen, -- we assume for now that it is not a By_Copy type. Clearly this -- attribute should not be used before the type is frozen, but it is -- needed to build the associated record of a protected type. Another -- place where some lookahead for a full view is needed ??? return Is_Elementary_Type (Ent) or else (Is_Private_Type (Ent) and then Present (Underlying_Type (Ent)) and then Is_Elementary_Type (Underlying_Type (Ent))); end Is_By_Copy_Type; -------------------------- -- Is_By_Reference_Type -- -------------------------- function Is_By_Reference_Type (Ent : Entity_Id) return Boolean is Btype : constant Entity_Id := Base_Type (Ent); begin if Error_Posted (Ent) or else Error_Posted (Btype) then return False; elsif Is_Private_Type (Btype) then declare Utyp : constant Entity_Id := Underlying_Type (Btype); begin if No (Utyp) then return False; else return Is_By_Reference_Type (Utyp); end if; end; elsif Is_Incomplete_Type (Btype) then declare Ftyp : constant Entity_Id := Full_View (Btype); begin if No (Ftyp) then return False; else return Is_By_Reference_Type (Ftyp); end if; end; elsif Is_Concurrent_Type (Btype) then return True; elsif Is_Record_Type (Btype) then if Is_Limited_Record (Btype) or else Is_Tagged_Type (Btype) or else Is_Volatile (Btype) then return True; else declare C : Entity_Id; begin C := First_Component (Btype); while Present (C) loop if Is_By_Reference_Type (Etype (C)) or else Is_Volatile (Etype (C)) then return True; end if; C := Next_Component (C); end loop; end; return False; end if; elsif Is_Array_Type (Btype) then return Is_Volatile (Btype) or else Is_By_Reference_Type (Component_Type (Btype)) or else Is_Volatile (Component_Type (Btype)) or else Has_Volatile_Components (Btype); else return False; end if; end Is_By_Reference_Type; --------------------- -- Is_Derived_Type -- --------------------- function Is_Derived_Type (Ent : E) return B is Par : Node_Id; begin if Is_Type (Ent) and then Base_Type (Ent) /= Root_Type (Ent) and then not Is_Class_Wide_Type (Ent) then if not Is_Numeric_Type (Root_Type (Ent)) then return True; else Par := Parent (First_Subtype (Ent)); return Present (Par) and then Nkind (Par) = N_Full_Type_Declaration and then Nkind (Type_Definition (Par)) = N_Derived_Type_Definition; end if; else return False; end if; end Is_Derived_Type; --------------------------- -- Is_Indefinite_Subtype -- --------------------------- function Is_Indefinite_Subtype (Ent : Entity_Id) return Boolean is K : constant Entity_Kind := Ekind (Ent); begin if Is_Constrained (Ent) then return False; elsif K in Array_Kind or else K in Class_Wide_Kind or else Has_Unknown_Discriminants (Ent) then return True; -- Known discriminants: indefinite if there are no default values elsif K in Record_Kind or else Is_Incomplete_Or_Private_Type (Ent) or else Is_Concurrent_Type (Ent) then return (Has_Discriminants (Ent) and then No (Discriminant_Default_Value (First_Discriminant (Ent)))); else return False; end if; end Is_Indefinite_Subtype; -------------------------------- -- Is_Inherently_Limited_Type -- -------------------------------- function Is_Inherently_Limited_Type (Ent : Entity_Id) return Boolean is Btype : constant Entity_Id := Base_Type (Ent); begin if Is_Private_Type (Btype) then declare Utyp : constant Entity_Id := Underlying_Type (Btype); begin if No (Utyp) then return False; else return Is_Inherently_Limited_Type (Utyp); end if; end; elsif Is_Concurrent_Type (Btype) then return True; elsif Is_Record_Type (Btype) then -- 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_Limited_Record (Btype) then return True; elsif Is_Class_Wide_Type (Btype) then return Is_Inherently_Limited_Type (Root_Type (Btype)); else declare C : Entity_Id; begin C := First_Component (Btype); while Present (C) loop -- 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 intefaces. if not Is_Interface (Etype (C)) and then Is_Inherently_Limited_Type (Etype (C)) then return True; end if; C := Next_Component (C); end loop; end; return False; end if; elsif Is_Array_Type (Btype) then return Is_Inherently_Limited_Type (Component_Type (Btype)); else return False; end if; end Is_Inherently_Limited_Type; --------------------- -- Is_Limited_Type -- --------------------- function Is_Limited_Type (Ent : Entity_Id) return Boolean is Btype : constant E := Base_Type (Ent); Rtype : constant E := Root_Type (Btype); begin if not Is_Type (Ent) then return False; elsif Ekind (Btype) = E_Limited_Private_Type or else Is_Limited_Composite (Btype) then return True; elsif Is_Concurrent_Type (Btype) then return True; -- The Is_Limited_Record flag normally indicates that the type is -- limited. The exception is that a type does not inherit limitedness -- from its interface ancestor. So the type may be derived from a -- limited interface, but is not limited. elsif Is_Limited_Record (Ent) and then not Is_Interface (Ent) then return True; -- Otherwise we will look around to see if there is some other reason -- for it to be limited, except that if an error was posted on the -- entity, then just assume it is non-limited, because it can cause -- trouble to recurse into a murky erroneous entity! elsif Error_Posted (Ent) then return False; elsif Is_Record_Type (Btype) then if Is_Limited_Interface (Ent) then return True; -- AI-419: limitedness is not inherited from a limited interface elsif Is_Limited_Record (Rtype) then return not Is_Interface (Rtype) or else Is_Protected_Interface (Rtype) or else Is_Synchronized_Interface (Rtype) or else Is_Task_Interface (Rtype); elsif Is_Class_Wide_Type (Btype) then return Is_Limited_Type (Rtype); else declare C : E; begin C := First_Component (Btype); while Present (C) loop if Is_Limited_Type (Etype (C)) then return True; end if; C := Next_Component (C); end loop; end; return False; end if; elsif Is_Array_Type (Btype) then return Is_Limited_Type (Component_Type (Btype)); else return False; end if; end Is_Limited_Type; --------------------------- -- 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 -- ------------------------ function Next_Tag_Component (Tag : Entity_Id) return Entity_Id is Comp : Entity_Id; 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 pragma Assert (Chars (Comp) /= Name_uTag); return Comp; end if; Comp := Next_Entity (Comp); end loop; -- No tag component found return Empty; end Next_Tag_Component; -------------------------- -- Number_Discriminants -- -------------------------- function Number_Discriminants (Typ : Entity_Id) return Pos is N : Int; Discr : Entity_Id; begin N := 0; Discr := First_Discriminant (Typ); while Present (Discr) loop N := N + 1; Discr := Next_Discriminant (Discr); end loop; return N; end Number_Discriminants; --------------- -- Tree_Read -- --------------- procedure Tree_Read is begin Obsolescent_Warnings.Tree_Read; end Tree_Read; ---------------- -- Tree_Write -- ---------------- procedure Tree_Write is begin Obsolescent_Warnings.Tree_Write; end Tree_Write; end Sem_Aux;
Go to most recent revision | Compare with Previous | Blame | View Log