diff options
Diffstat (limited to 'gcc-4.2.1/gcc/ada/exp_ch8.adb')
| -rw-r--r-- | gcc-4.2.1/gcc/ada/exp_ch8.adb | 318 |
1 files changed, 318 insertions, 0 deletions
diff --git a/gcc-4.2.1/gcc/ada/exp_ch8.adb b/gcc-4.2.1/gcc/ada/exp_ch8.adb new file mode 100644 index 000000000..846b10d41 --- /dev/null +++ b/gcc-4.2.1/gcc/ada/exp_ch8.adb @@ -0,0 +1,318 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 8 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2004 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 2, 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 COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- 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_Dbug; use Exp_Dbug; +with Exp_Util; use Exp_Util; +with Freeze; use Freeze; +with Nlists; use Nlists; +with Sem; use Sem; +with Sem_Ch8; use Sem_Ch8; +with Sinfo; use Sinfo; +with Stand; use Stand; +with Targparm; use Targparm; + +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 K = N_Indexed_Component + or else K = 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 (Nam) = N_Indexed_Component + or else Nkind (Nam) = 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. This is + -- required for targets where Frontend_Layout_On_Target is true. + -- For targets where Gigi is used, class-wide subtype should not + -- be frozen (in that case the subtype is marked as already frozen + -- when it's created). + + if Frontend_Layout_On_Target then + Freeze_Before (N, Entity (Subtype_Mark (N))); + end if; + 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 + New_Scope (Standard_Standard); + + if No (Actions (Aux)) then + Set_Actions (Aux, New_List (Decl)); + else + Append (Decl, Actions (Aux)); + end if; + + Analyze (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; + +end Exp_Ch8; |