1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Einfo; use Einfo;
28 with Exp_Attr; use Exp_Attr;
29 with Exp_Ch4; use Exp_Ch4;
30 with Exp_Ch6; use Exp_Ch6;
31 with Exp_Dbug; use Exp_Dbug;
32 with Exp_Util; use Exp_Util;
33 with Nlists; use Nlists;
34 with Rtsfind; use Rtsfind;
35 with Sem_Aux; use Sem_Aux;
36 with Sem_Res; use Sem_Res;
37 with Sem_Util; use Sem_Util;
38 with Sinfo; use Sinfo;
39 with Snames; use Snames;
40 with Stand; use Stand;
41 with Tbuild; use Tbuild;
43 package body Exp_Alfa is
45 -----------------------
46 -- Local Subprograms --
47 -----------------------
49 procedure Expand_Alfa_Call (N : Node_Id);
50 -- This procedure contains common processing for function and procedure
52 -- * expansion of actuals to introduce necessary temporaries
53 -- * replacement of renaming by subprogram renamed
55 procedure Expand_Alfa_N_Attribute_Reference (N : Node_Id);
56 -- Expand attributes 'Old and 'Result only
58 procedure Expand_Alfa_N_In (N : Node_Id);
59 -- Expand set membership into individual ones
61 procedure Expand_Alfa_N_Object_Renaming_Declaration (N : Node_Id);
62 -- Perform name evaluation for a renamed object
64 procedure Expand_Alfa_N_Simple_Return_Statement (N : Node_Id);
65 -- Insert conversion on function return if necessary
67 procedure Expand_Alfa_Simple_Function_Return (N : Node_Id);
68 -- Expand simple return from function
70 procedure Expand_Potential_Renaming (N : Node_Id);
71 -- N denotes a N_Identifier or N_Expanded_Name. If N references a renaming,
72 -- replace N with the renamed object.
78 procedure Expand_Alfa (N : Node_Id) is
81 when N_Attribute_Reference =>
82 Expand_Alfa_N_Attribute_Reference (N);
84 when N_Block_Statement |
86 N_Package_Declaration |
88 Qualify_Entity_Names (N);
90 when N_Function_Call |
91 N_Procedure_Call_Statement =>
94 when N_Expanded_Name |
96 Expand_Potential_Renaming (N);
104 when N_Object_Renaming_Declaration =>
105 Expand_Alfa_N_Object_Renaming_Declaration (N);
107 when N_Simple_Return_Statement =>
108 Expand_Alfa_N_Simple_Return_Statement (N);
115 ----------------------
116 -- Expand_Alfa_Call --
117 ----------------------
119 procedure Expand_Alfa_Call (N : Node_Id) is
120 Call_Node : constant Node_Id := N;
121 Parent_Subp : Entity_Id;
125 -- Ignore if previous error
127 if Nkind (Call_Node) in N_Has_Etype
128 and then Etype (Call_Node) = Any_Type
133 -- Call using access to subprogram with explicit dereference
135 if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
136 Subp := Etype (Name (Call_Node));
137 Parent_Subp := Empty;
139 -- Case of call to simple entry, where the Name is a selected component
140 -- whose prefix is the task, and whose selector name is the entry name
142 elsif Nkind (Name (Call_Node)) = N_Selected_Component then
143 Subp := Entity (Selector_Name (Name (Call_Node)));
144 Parent_Subp := Empty;
146 -- Case of call to member of entry family, where Name is an indexed
147 -- component, with the prefix being a selected component giving the
148 -- task and entry family name, and the index being the entry index.
150 elsif Nkind (Name (Call_Node)) = N_Indexed_Component then
151 Subp := Entity (Selector_Name (Prefix (Name (Call_Node))));
152 Parent_Subp := Empty;
157 Subp := Entity (Name (Call_Node));
158 Parent_Subp := Alias (Subp);
161 -- Various expansion activities for actuals are carried out
163 Expand_Actuals (N, Subp);
165 -- If the subprogram is a renaming, replace it in the call with the name
166 -- of the actual subprogram being called.
168 if Present (Parent_Subp) then
169 Parent_Subp := Ultimate_Alias (Parent_Subp);
171 -- The below setting of Entity is suspect, see F109-018 discussion???
173 Set_Entity (Name (Call_Node), Parent_Subp);
175 end Expand_Alfa_Call;
177 ---------------------------------------
178 -- Expand_Alfa_N_Attribute_Reference --
179 ---------------------------------------
181 procedure Expand_Alfa_N_Attribute_Reference (N : Node_Id) is
182 Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
188 Expand_N_Attribute_Reference (N);
193 end Expand_Alfa_N_Attribute_Reference;
195 ----------------------
196 -- Expand_Alfa_N_In --
197 ----------------------
199 procedure Expand_Alfa_N_In (N : Node_Id) is
201 if Present (Alternatives (N)) then
202 Expand_Set_Membership (N);
204 end Expand_Alfa_N_In;
206 -----------------------------------------------
207 -- Expand_Alfa_N_Object_Renaming_Declaration --
208 -----------------------------------------------
210 procedure Expand_Alfa_N_Object_Renaming_Declaration (N : Node_Id) is
212 -- Unconditionally remove all side effects from the name
214 Evaluate_Name (Name (N));
215 end Expand_Alfa_N_Object_Renaming_Declaration;
217 -------------------------------------------
218 -- Expand_Alfa_N_Simple_Return_Statement --
219 -------------------------------------------
221 procedure Expand_Alfa_N_Simple_Return_Statement (N : Node_Id) is
223 -- Defend against previous errors (i.e. the return statement calls a
224 -- function that is not available in configurable runtime).
226 if Present (Expression (N))
227 and then Nkind (Expression (N)) = N_Empty
232 -- Distinguish the function and non-function cases:
234 case Ekind (Return_Applies_To (Return_Statement_Entity (N))) is
237 E_Generic_Function =>
238 Expand_Alfa_Simple_Function_Return (N);
241 E_Generic_Procedure |
244 E_Return_Statement =>
252 when RE_Not_Available =>
254 end Expand_Alfa_N_Simple_Return_Statement;
256 ----------------------------------------
257 -- Expand_Alfa_Simple_Function_Return --
258 ----------------------------------------
260 procedure Expand_Alfa_Simple_Function_Return (N : Node_Id) is
261 Scope_Id : constant Entity_Id :=
262 Return_Applies_To (Return_Statement_Entity (N));
263 -- The function we are returning from
265 R_Type : constant Entity_Id := Etype (Scope_Id);
266 -- The result type of the function
268 Exp : constant Node_Id := Expression (N);
269 pragma Assert (Present (Exp));
271 Exptyp : constant Entity_Id := Etype (Exp);
272 -- The type of the expression (not necessarily the same as R_Type)
275 -- Check the result expression of a scalar function against the subtype
276 -- of the function by inserting a conversion. This conversion must
277 -- eventually be performed for other classes of types, but for now it's
278 -- only done for scalars.
281 if Is_Scalar_Type (Exptyp) then
282 Rewrite (Exp, Convert_To (R_Type, Exp));
284 -- The expression is resolved to ensure that the conversion gets
285 -- expanded to generate a possible constraint check.
287 Analyze_And_Resolve (Exp, R_Type);
289 end Expand_Alfa_Simple_Function_Return;
291 -------------------------------
292 -- Expand_Potential_Renaming --
293 -------------------------------
295 procedure Expand_Potential_Renaming (N : Node_Id) is
296 E : constant Entity_Id := Entity (N);
297 T : constant Entity_Id := Etype (N);
300 -- Replace a reference to a renaming with the actual renamed object
302 if Ekind (E) in Object_Kind and then Present (Renamed_Object (E)) then
303 Rewrite (N, New_Copy_Tree (Renamed_Object (E)));
304 Reset_Analyzed_Flags (N);
305 Analyze_And_Resolve (N, T);
307 end Expand_Potential_Renaming;