diff options
author | Richard Kenner <kenner@gcc.gnu.org> | 2001-10-02 10:08:34 -0400 |
---|---|---|
committer | Richard Kenner <kenner@gcc.gnu.org> | 2001-10-02 10:08:34 -0400 |
commit | 70482933d8f6a73b660f4cfa97b5c7c9deaf152e (patch) | |
tree | 133a71d6793865f2028234c0125afcfa4c7afc76 /gcc/ada/exp_ch8.adb | |
parent | d23b8f573b3dcbfc04d13387885059de809aec50 (diff) | |
download | gcc-70482933d8f6a73b660f4cfa97b5c7c9deaf152e.zip gcc-70482933d8f6a73b660f4cfa97b5c7c9deaf152e.tar.gz gcc-70482933d8f6a73b660f4cfa97b5c7c9deaf152e.tar.bz2 |
New Language: Ada
From-SVN: r45954
Diffstat (limited to 'gcc/ada/exp_ch8.adb')
-rw-r--r-- | gcc/ada/exp_ch8.adb | 282 |
1 files changed, 282 insertions, 0 deletions
diff --git a/gcc/ada/exp_ch8.adb b/gcc/ada/exp_ch8.adb new file mode 100644 index 0000000..54b1133 --- /dev/null +++ b/gcc/ada/exp_ch8.adb @@ -0,0 +1,282 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 8 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.27 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Einfo; use Einfo; +with Exp_Dbug; use Exp_Dbug; +with Exp_Util; use Exp_Util; +with Nlists; use Nlists; +with Sem; use Sem; +with Sem_Ch8; use Sem_Ch8; +with Sinfo; use Sinfo; +with Stand; use Stand; + +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). + + -- 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. + + -- 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 : 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 + if Present (Component_Clause (Entity (Selector_Name (Nam)))) then + return True; + else + return Evaluation_Required (Prefix (Nam)); + end if; + + 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))); + 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; |