blob: 0670362fa9eaecc8fc177922a9a4e945c7d0f1fa [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E X P _ C H 8 --
-- --
-- B o d y --
-- --
-- $Revision$
-- --
-- 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), 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 : 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 : 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)));
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;