| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- E X P _ C H 8 -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2010, 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); |
| T : Entity_Id; |
| Decl : Node_Id; |
| |
| procedure Evaluate_Name (Fname : Node_Id); |
| -- A recursive procedure used to freeze a name in the sense described |
| -- above, i.e. any variable references or function calls are removed. |
| -- Of course the outer level variable reference must not be removed. |
| -- For example in A(J,F(K)), A is left as is, but J and F(K) are |
| -- evaluated and removed. |
| |
| 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. |
| |
| ------------------- |
| -- Evaluate_Name -- |
| ------------------- |
| |
| procedure Evaluate_Name (Fname : Node_Id) is |
| K : constant Node_Kind := Nkind (Fname); |
| E : Node_Id; |
| |
| begin |
| -- For an explicit dereference, we simply force the evaluation |
| -- of the name expression. The dereference provides a value that |
| -- is the address for the renamed object, and it is precisely |
| -- this value that we want to preserve. |
| |
| if K = N_Explicit_Dereference then |
| Force_Evaluation (Prefix (Fname)); |
| |
| -- For a selected component, we simply evaluate the prefix |
| |
| elsif K = N_Selected_Component then |
| Evaluate_Name (Prefix (Fname)); |
| |
| -- For an indexed component, or an attribute reference, we evaluate |
| -- the prefix, which is itself a name, recursively, and then force |
| -- the evaluation of all the subscripts (or attribute expressions). |
| |
| elsif Nkind_In (K, N_Indexed_Component, N_Attribute_Reference) then |
| Evaluate_Name (Prefix (Fname)); |
| |
| E := First (Expressions (Fname)); |
| while Present (E) loop |
| Force_Evaluation (E); |
| |
| if Original_Node (E) /= E then |
| Set_Do_Range_Check (E, Do_Range_Check (Original_Node (E))); |
| end if; |
| |
| Next (E); |
| end loop; |
| |
| -- For a slice, we evaluate the prefix, as for the indexed component |
| -- case and then, if there is a range present, either directly or |
| -- as the constraint of a discrete subtype indication, we evaluate |
| -- the two bounds of this range. |
| |
| elsif K = N_Slice then |
| Evaluate_Name (Prefix (Fname)); |
| |
| declare |
| DR : constant Node_Id := Discrete_Range (Fname); |
| Constr : Node_Id; |
| Rexpr : Node_Id; |
| |
| begin |
| if Nkind (DR) = N_Range then |
| Force_Evaluation (Low_Bound (DR)); |
| Force_Evaluation (High_Bound (DR)); |
| |
| elsif Nkind (DR) = N_Subtype_Indication then |
| Constr := Constraint (DR); |
| |
| if Nkind (Constr) = N_Range_Constraint then |
| Rexpr := Range_Expression (Constr); |
| |
| Force_Evaluation (Low_Bound (Rexpr)); |
| Force_Evaluation (High_Bound (Rexpr)); |
| end if; |
| end if; |
| end; |
| |
| -- For a type conversion, the expression of the conversion must be |
| -- the name of an object, and we simply need to evaluate this name. |
| |
| elsif K = N_Type_Conversion then |
| Evaluate_Name (Expression (Fname)); |
| |
| -- For a function call, we evaluate the call |
| |
| elsif K = N_Function_Call then |
| Force_Evaluation (Fname); |
| |
| -- The remaining cases are direct name, operator symbol and |
| -- character literal. In all these cases, we do nothing, since |
| -- we want to reevaluate each time the renamed object is used. |
| |
| else |
| return; |
| end if; |
| end Evaluate_Name; |
| |
| ------------------------- |
| -- 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; |
