URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [exp_ch8.adb] - Rev 848
Go to most recent revision | Compare with Previous | Blame | View Log
------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ C H 8 -- -- -- -- B o d y -- -- -- -- 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- -- -- 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. -- -- -- -- 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 Exp_Ch4; use Exp_Ch4; with Exp_Ch6; use Exp_Ch6; with Exp_Dbug; use Exp_Dbug; with Exp_Util; use Exp_Util; with Freeze; use Freeze; with Namet; use Namet; with Nmake; use Nmake; with Nlists; use Nlists; with Opt; use Opt; with Sem; use Sem; with Sem_Ch8; use Sem_Ch8; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Tbuild; use Tbuild; package body Exp_Ch8 is --------------------------------------------- -- Expand_N_Exception_Renaming_Declaration -- --------------------------------------------- procedure Expand_N_Exception_Renaming_Declaration (N : Node_Id) is Decl : constant Node_Id := Debug_Renaming_Declaration (N); begin if Present (Decl) then Insert_Action (N, Decl); end if; end Expand_N_Exception_Renaming_Declaration; ------------------------------------------ -- Expand_N_Object_Renaming_Declaration -- ------------------------------------------ -- Most object renaming cases can be done by just capturing the address -- of the renamed object. The cases in which this is not true are when -- this address is not computable, since it involves extraction of a -- packed array element, or of a record component to which a component -- clause applies (that can specify an arbitrary bit boundary), or where -- the enclosing record itself has a non-standard representation. -- In these two cases, we pre-evaluate the renaming expression, by -- extracting and freezing the values of any subscripts, and then we -- set the flag Is_Renaming_Of_Object which means that any reference -- to the object will be handled by macro substitution in the front -- end, and the back end will know to ignore the renaming declaration. -- An additional odd case that requires processing by expansion is -- the renaming of a discriminant of a mutable record type. The object -- is a constant because it renames something that cannot be assigned to, -- but in fact the underlying value can change and must be reevaluated -- at each reference. Gigi does have a notion of a "constant view" of -- an object, and therefore the front-end must perform the expansion. -- For simplicity, and to bypass some obscure code-generation problem, -- we use macro substitution for all renamed discriminants, whether the -- enclosing type is constrained or not. -- The other special processing required is for the case of renaming -- of an object of a class wide type, where it is necessary to build -- the appropriate subtype for the renamed object. -- More comments needed for this para ??? procedure Expand_N_Object_Renaming_Declaration (N : Node_Id) is Nam : constant Node_Id := Name (N); Decl : Node_Id; T : Entity_Id; function Evaluation_Required (Nam : Node_Id) return Boolean; -- Determines whether it is necessary to do static name evaluation for -- renaming of Nam. It is considered necessary if evaluating the name -- involves indexing a packed array, or extracting a component of a -- record to which a component clause applies. Note that we are only -- interested in these operations if they occur as part of the name -- itself, subscripts are just values that are computed as part of the -- evaluation, so their form is unimportant. ------------------------- -- Evaluation_Required -- ------------------------- function Evaluation_Required (Nam : Node_Id) return Boolean is begin if Nkind_In (Nam, N_Indexed_Component, N_Slice) then if Is_Packed (Etype (Prefix (Nam))) then return True; else return Evaluation_Required (Prefix (Nam)); end if; elsif Nkind (Nam) = N_Selected_Component then declare Rec_Type : constant Entity_Id := Etype (Prefix (Nam)); begin if Present (Component_Clause (Entity (Selector_Name (Nam)))) or else Has_Non_Standard_Rep (Rec_Type) then return True; elsif Ekind (Entity (Selector_Name (Nam))) = E_Discriminant and then Is_Record_Type (Rec_Type) and then not Is_Concurrent_Record_Type (Rec_Type) then return True; else return Evaluation_Required (Prefix (Nam)); end if; end; else return False; end if; end Evaluation_Required; -- Start of processing for Expand_N_Object_Renaming_Declaration begin -- Perform name evaluation if required if Evaluation_Required (Nam) then Evaluate_Name (Nam); Set_Is_Renaming_Of_Object (Defining_Identifier (N)); end if; -- Deal with construction of subtype in class-wide case T := Etype (Defining_Identifier (N)); if Is_Class_Wide_Type (T) then Expand_Subtype_From_Expr (N, T, Subtype_Mark (N), Name (N)); Find_Type (Subtype_Mark (N)); Set_Etype (Defining_Identifier (N), Entity (Subtype_Mark (N))); -- Freeze the class-wide subtype here to ensure that the subtype -- and equivalent type are frozen before the renaming. Freeze_Before (N, Entity (Subtype_Mark (N))); end if; -- Ada 2005 (AI-318-02): If the renamed object is a call to a build-in- -- place function, then a temporary return object needs to be created -- and access to it must be passed to the function. Currently we limit -- such functions to those with inherently limited result subtypes, but -- eventually we plan to expand the functions that are treated as -- build-in-place to include other composite result types. if Ada_Version >= Ada_2005 and then Is_Build_In_Place_Function_Call (Nam) then Make_Build_In_Place_Call_In_Anonymous_Context (Nam); end if; -- Create renaming entry for debug information Decl := Debug_Renaming_Declaration (N); if Present (Decl) then Insert_Action (N, Decl); end if; end Expand_N_Object_Renaming_Declaration; ------------------------------------------- -- Expand_N_Package_Renaming_Declaration -- ------------------------------------------- procedure Expand_N_Package_Renaming_Declaration (N : Node_Id) is Decl : constant Node_Id := Debug_Renaming_Declaration (N); begin if Present (Decl) then -- If we are in a compilation unit, then this is an outer -- level declaration, and must have a scope of Standard if Nkind (Parent (N)) = N_Compilation_Unit then declare Aux : constant Node_Id := Aux_Decls_Node (Parent (N)); begin Push_Scope (Standard_Standard); if No (Actions (Aux)) then Set_Actions (Aux, New_List (Decl)); else Append (Decl, Actions (Aux)); end if; Analyze (Decl); -- Enter the debug variable in the qualification list, which -- must be done at this point because auxiliary declarations -- occur at the library level and aren't associated with a -- normal scope. Qualify_Entity_Names (Decl); Pop_Scope; end; -- Otherwise, just insert after the package declaration else Insert_Action (N, Decl); end if; end if; end Expand_N_Package_Renaming_Declaration; ---------------------------------------------- -- Expand_N_Subprogram_Renaming_Declaration -- ---------------------------------------------- procedure Expand_N_Subprogram_Renaming_Declaration (N : Node_Id) is Nam : constant Node_Id := Name (N); begin -- When the prefix of the name is a function call, we must force the -- call to be made by removing side effects from the call, since we -- must only call the function once. if Nkind (Nam) = N_Selected_Component and then Nkind (Prefix (Nam)) = N_Function_Call then Remove_Side_Effects (Prefix (Nam)); -- For an explicit dereference, the prefix must be captured to prevent -- reevaluation on calls through the renaming, which could result in -- calling the wrong subprogram if the access value were to be changed. elsif Nkind (Nam) = N_Explicit_Dereference then Force_Evaluation (Prefix (Nam)); end if; -- Check whether this is a renaming of a predefined equality on an -- untagged record type (AI05-0123). if Is_Entity_Name (Nam) and then Chars (Entity (Nam)) = Name_Op_Eq and then Scope (Entity (Nam)) = Standard_Standard and then Ada_Version >= Ada_2012 then declare Loc : constant Source_Ptr := Sloc (N); Id : constant Entity_Id := Defining_Entity (N); Typ : constant Entity_Id := Etype (First_Formal (Id)); Decl : Node_Id; Body_Id : constant Entity_Id := Make_Defining_Identifier (Sloc (N), Chars (Id)); begin if Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) and then not Is_Frozen (Typ) then -- Build body for renamed equality, to capture its current -- meaning. It may be redefined later, but the renaming is -- elaborated where it occurs. This is technically known as -- Squirreling semantics. Renaming is rewritten as a subprogram -- declaration, and the body is inserted at the end of the -- current declaration list to prevent premature freezing. Set_Alias (Id, Empty); Set_Has_Completion (Id, False); Rewrite (N, Make_Subprogram_Declaration (Sloc (N), Specification => Specification (N))); Set_Has_Delayed_Freeze (Id); Decl := Make_Subprogram_Body (Loc, Specification => Make_Function_Specification (Loc, Defining_Unit_Name => Body_Id, Parameter_Specifications => Copy_Parameter_List (Id), Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)), Declarations => Empty_List, Handled_Statement_Sequence => Empty); Set_Handled_Statement_Sequence (Decl, Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List ( Make_Simple_Return_Statement (Loc, Expression => Expand_Record_Equality (Id, Typ => Typ, Lhs => Make_Identifier (Loc, Chars (First_Formal (Id))), Rhs => Make_Identifier (Loc, Chars (Next_Formal (First_Formal (Id)))), Bodies => Declarations (Decl)))))); Append (Decl, List_Containing (N)); Set_Debug_Info_Needed (Body_Id); end if; end; end if; end Expand_N_Subprogram_Renaming_Declaration; end Exp_Ch8;
Go to most recent revision | Compare with Previous | Blame | View Log