1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- Extensive contributions were provided by Ada Core Technologies Inc. --
26 ------------------------------------------------------------------------------
28 with Atree
; use Atree
;
29 with Einfo
; use Einfo
;
30 with Exp_Dbug
; use Exp_Dbug
;
31 with Exp_Util
; use Exp_Util
;
32 with Nlists
; use Nlists
;
34 with Sem_Ch8
; use Sem_Ch8
;
35 with Sinfo
; use Sinfo
;
36 with Stand
; use Stand
;
38 package body Exp_Ch8
is
40 ---------------------------------------------
41 -- Expand_N_Exception_Renaming_Declaration --
42 ---------------------------------------------
44 procedure Expand_N_Exception_Renaming_Declaration
(N
: Node_Id
) is
45 Decl
: constant Node_Id
:= Debug_Renaming_Declaration
(N
);
48 if Present
(Decl
) then
49 Insert_Action
(N
, Decl
);
51 end Expand_N_Exception_Renaming_Declaration
;
53 ------------------------------------------
54 -- Expand_N_Object_Renaming_Declaration --
55 ------------------------------------------
57 -- Most object renaming cases can be done by just capturing the address
58 -- of the renamed object. The cases in which this is not true are when
59 -- this address is not computable, since it involves extraction of a
60 -- packed array element, or of a record component to which a component
61 -- clause applies (that can specify an arbitrary bit boundary), or where
62 -- the enclosing record itself has a non-standard representation.
64 -- In these two cases, we pre-evaluate the renaming expression, by
65 -- extracting and freezing the values of any subscripts, and then we
66 -- set the flag Is_Renaming_Of_Object which means that any reference
67 -- to the object will be handled by macro substitution in the front
68 -- end, and the back end will know to ignore the renaming declaration.
70 -- An additional odd case that requires processing by expansion is
71 -- the renaming of a discriminant of a mutable record type. The object
72 -- is a constant because it renames something that cannot be assigned to,
73 -- but in fact the underlying value can change and must be reevaluated
74 -- at each reference. Gigi does have a notion of a "constant view" of
75 -- an object, and therefore the front-end must perform the expansion.
76 -- For simplicity, and to bypass some obscure code-generation problem,
77 -- we use macro substitution for all renamed discriminants, whether the
78 -- enclosing type is constrained or not.
80 -- The other special processing required is for the case of renaming
81 -- of an object of a class wide type, where it is necessary to build
82 -- the appropriate subtype for the renamed object.
83 -- More comments needed for this para ???
85 procedure Expand_N_Object_Renaming_Declaration
(N
: Node_Id
) is
86 Nam
: Node_Id
:= Name
(N
);
90 procedure Evaluate_Name
(Fname
: Node_Id
);
91 -- A recursive procedure used to freeze a name in the sense described
92 -- above, i.e. any variable references or function calls are removed.
93 -- Of course the outer level variable reference must not be removed.
94 -- For example in A(J,F(K)), A is left as is, but J and F(K) are
95 -- evaluated and removed.
97 function Evaluation_Required
(Nam
: Node_Id
) return Boolean;
98 -- Determines whether it is necessary to do static name evaluation
99 -- for renaming of Nam. It is considered necessary if evaluating the
100 -- name involves indexing a packed array, or extracting a component
101 -- of a record to which a component clause applies. Note that we are
102 -- only interested in these operations if they occur as part of the
103 -- name itself, subscripts are just values that are computed as part
104 -- of the evaluation, so their form is unimportant.
110 procedure Evaluate_Name
(Fname
: Node_Id
) is
111 K
: constant Node_Kind
:= Nkind
(Fname
);
115 -- For an explicit dereference, we simply force the evaluation
116 -- of the name expression. The dereference provides a value that
117 -- is the address for the renamed object, and it is precisely
118 -- this value that we want to preserve.
120 if K
= N_Explicit_Dereference
then
121 Force_Evaluation
(Prefix
(Fname
));
123 -- For a selected component, we simply evaluate the prefix
125 elsif K
= N_Selected_Component
then
126 Evaluate_Name
(Prefix
(Fname
));
128 -- For an indexed component, or an attribute reference, we evaluate
129 -- the prefix, which is itself a name, recursively, and then force
130 -- the evaluation of all the subscripts (or attribute expressions).
132 elsif K
= N_Indexed_Component
133 or else K
= N_Attribute_Reference
135 Evaluate_Name
(Prefix
(Fname
));
137 E
:= First
(Expressions
(Fname
));
138 while Present
(E
) loop
139 Force_Evaluation
(E
);
141 if Original_Node
(E
) /= E
then
142 Set_Do_Range_Check
(E
, Do_Range_Check
(Original_Node
(E
)));
148 -- For a slice, we evaluate the prefix, as for the indexed component
149 -- case and then, if there is a range present, either directly or
150 -- as the constraint of a discrete subtype indication, we evaluate
151 -- the two bounds of this range.
153 elsif K
= N_Slice
then
154 Evaluate_Name
(Prefix
(Fname
));
157 DR
: constant Node_Id
:= Discrete_Range
(Fname
);
162 if Nkind
(DR
) = N_Range
then
163 Force_Evaluation
(Low_Bound
(DR
));
164 Force_Evaluation
(High_Bound
(DR
));
166 elsif Nkind
(DR
) = N_Subtype_Indication
then
167 Constr
:= Constraint
(DR
);
169 if Nkind
(Constr
) = N_Range_Constraint
then
170 Rexpr
:= Range_Expression
(Constr
);
172 Force_Evaluation
(Low_Bound
(Rexpr
));
173 Force_Evaluation
(High_Bound
(Rexpr
));
178 -- For a type conversion, the expression of the conversion must be
179 -- the name of an object, and we simply need to evaluate this name.
181 elsif K
= N_Type_Conversion
then
182 Evaluate_Name
(Expression
(Fname
));
184 -- For a function call, we evaluate the call.
186 elsif K
= N_Function_Call
then
187 Force_Evaluation
(Fname
);
189 -- The remaining cases are direct name, operator symbol and
190 -- character literal. In all these cases, we do nothing, since
191 -- we want to reevaluate each time the renamed object is used.
198 -------------------------
199 -- Evaluation_Required --
200 -------------------------
202 function Evaluation_Required
(Nam
: Node_Id
) return Boolean is
204 if Nkind
(Nam
) = N_Indexed_Component
205 or else Nkind
(Nam
) = N_Slice
207 if Is_Packed
(Etype
(Prefix
(Nam
))) then
210 return Evaluation_Required
(Prefix
(Nam
));
213 elsif Nkind
(Nam
) = N_Selected_Component
then
215 Rec_Type
: Entity_Id
:= Etype
(Prefix
(Nam
));
218 if Present
(Component_Clause
(Entity
(Selector_Name
(Nam
))))
219 or else Has_Non_Standard_Rep
(Rec_Type
)
223 elsif Ekind
(Entity
(Selector_Name
(Nam
))) = E_Discriminant
224 and then Is_Record_Type
(Rec_Type
)
225 and then not Is_Concurrent_Record_Type
(Rec_Type
)
230 return Evaluation_Required
(Prefix
(Nam
));
237 end Evaluation_Required
;
239 -- Start of processing for Expand_N_Object_Renaming_Declaration
242 -- Perform name evaluation if required
244 if Evaluation_Required
(Nam
) then
246 Set_Is_Renaming_Of_Object
(Defining_Identifier
(N
));
249 -- Deal with construction of subtype in class-wide case
251 T
:= Etype
(Defining_Identifier
(N
));
253 if Is_Class_Wide_Type
(T
) then
254 Expand_Subtype_From_Expr
(N
, T
, Subtype_Mark
(N
), Name
(N
));
255 Find_Type
(Subtype_Mark
(N
));
256 Set_Etype
(Defining_Identifier
(N
), Entity
(Subtype_Mark
(N
)));
259 -- Create renaming entry for debug information
261 Decl
:= Debug_Renaming_Declaration
(N
);
263 if Present
(Decl
) then
264 Insert_Action
(N
, Decl
);
266 end Expand_N_Object_Renaming_Declaration
;
268 -------------------------------------------
269 -- Expand_N_Package_Renaming_Declaration --
270 -------------------------------------------
272 procedure Expand_N_Package_Renaming_Declaration
(N
: Node_Id
) is
273 Decl
: constant Node_Id
:= Debug_Renaming_Declaration
(N
);
276 if Present
(Decl
) then
278 -- If we are in a compilation unit, then this is an outer
279 -- level declaration, and must have a scope of Standard
281 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
283 Aux
: constant Node_Id
:= Aux_Decls_Node
(Parent
(N
));
286 New_Scope
(Standard_Standard
);
288 if No
(Actions
(Aux
)) then
289 Set_Actions
(Aux
, New_List
(Decl
));
291 Append
(Decl
, Actions
(Aux
));
298 -- Otherwise, just insert after the package declaration
301 Insert_Action
(N
, Decl
);
304 end Expand_N_Package_Renaming_Declaration
;