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 Nlists; use Nlists;
33 with Rtsfind; use Rtsfind;
34 with Sem_Aux; use Sem_Aux;
35 with Sem_Res; use Sem_Res;
36 with Sinfo; use Sinfo;
37 with Snames; use Snames;
38 with Stand; use Stand;
39 with Tbuild; use Tbuild;
41 package body Exp_Alfa is
43 -----------------------
44 -- Local Subprograms --
45 -----------------------
47 procedure Expand_Alfa_Call (N : Node_Id);
48 -- This procedure contains common processing for function and procedure
50 -- * expansion of actuals to introduce necessary temporaries
51 -- * replacement of renaming by subprogram renamed
53 procedure Expand_Alfa_N_Attribute_Reference (N : Node_Id);
54 -- Expand attributes 'Old and 'Result only
56 procedure Expand_Alfa_N_In (N : Node_Id);
57 -- Expand set membership into individual ones
59 procedure Expand_Alfa_N_Simple_Return_Statement (N : Node_Id);
60 -- Insert conversion on function return if necessary
62 procedure Expand_Alfa_Simple_Function_Return (N : Node_Id);
63 -- Expand simple return from function
69 procedure Expand_Alfa (N : Node_Id) is
74 N_Package_Declaration |
77 Qualify_Entity_Names (N);
79 when N_Simple_Return_Statement =>
80 Expand_Alfa_N_Simple_Return_Statement (N);
82 when N_Function_Call |
83 N_Procedure_Call_Statement =>
86 when N_Attribute_Reference =>
87 Expand_Alfa_N_Attribute_Reference (N);
100 ----------------------
101 -- Expand_Alfa_Call --
102 ----------------------
104 procedure Expand_Alfa_Call (N : Node_Id) is
105 Call_Node : constant Node_Id := N;
106 Parent_Subp : Entity_Id;
110 -- Ignore if previous error
112 if Nkind (Call_Node) in N_Has_Etype
113 and then Etype (Call_Node) = Any_Type
118 -- Call using access to subprogram with explicit dereference
120 if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
121 Subp := Etype (Name (Call_Node));
122 Parent_Subp := Empty;
124 -- Case of call to simple entry, where the Name is a selected component
125 -- whose prefix is the task, and whose selector name is the entry name
127 elsif Nkind (Name (Call_Node)) = N_Selected_Component then
128 Subp := Entity (Selector_Name (Name (Call_Node)));
129 Parent_Subp := Empty;
131 -- Case of call to member of entry family, where Name is an indexed
132 -- component, with the prefix being a selected component giving the
133 -- task and entry family name, and the index being the entry index.
135 elsif Nkind (Name (Call_Node)) = N_Indexed_Component then
136 Subp := Entity (Selector_Name (Prefix (Name (Call_Node))));
137 Parent_Subp := Empty;
142 Subp := Entity (Name (Call_Node));
143 Parent_Subp := Alias (Subp);
146 -- Various expansion activities for actuals are carried out
148 Expand_Actuals (N, Subp);
150 -- If the subprogram is a renaming, replace it in the call with the name
151 -- of the actual subprogram being called.
153 if Present (Parent_Subp) then
154 Parent_Subp := Ultimate_Alias (Parent_Subp);
156 -- The below setting of Entity is suspect, see F109-018 discussion???
158 Set_Entity (Name (Call_Node), Parent_Subp);
161 end Expand_Alfa_Call;
163 ---------------------------------------
164 -- Expand_Alfa_N_Attribute_Reference --
165 ---------------------------------------
167 procedure Expand_Alfa_N_Attribute_Reference (N : Node_Id) is
168 Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
174 Expand_N_Attribute_Reference (N);
179 end Expand_Alfa_N_Attribute_Reference;
181 ----------------------
182 -- Expand_Alfa_N_In --
183 ----------------------
185 procedure Expand_Alfa_N_In (N : Node_Id) is
187 if Present (Alternatives (N)) then
188 Expand_Set_Membership (N);
191 end Expand_Alfa_N_In;
193 -------------------------------------------
194 -- Expand_Alfa_N_Simple_Return_Statement --
195 -------------------------------------------
197 procedure Expand_Alfa_N_Simple_Return_Statement (N : Node_Id) is
199 -- Defend against previous errors (i.e. the return statement calls a
200 -- function that is not available in configurable runtime).
202 if Present (Expression (N))
203 and then Nkind (Expression (N)) = N_Empty
208 -- Distinguish the function and non-function cases:
210 case Ekind (Return_Applies_To (Return_Statement_Entity (N))) is
213 E_Generic_Function =>
214 Expand_Alfa_Simple_Function_Return (N);
217 E_Generic_Procedure |
220 E_Return_Statement =>
221 -- Expand_Non_Function_Return (N);
229 when RE_Not_Available =>
231 end Expand_Alfa_N_Simple_Return_Statement;
233 ----------------------------------------
234 -- Expand_Alfa_Simple_Function_Return --
235 ----------------------------------------
237 procedure Expand_Alfa_Simple_Function_Return (N : Node_Id) is
238 Scope_Id : constant Entity_Id :=
239 Return_Applies_To (Return_Statement_Entity (N));
240 -- The function we are returning from
242 R_Type : constant Entity_Id := Etype (Scope_Id);
243 -- The result type of the function
245 Exp : constant Node_Id := Expression (N);
246 pragma Assert (Present (Exp));
248 Exptyp : constant Entity_Id := Etype (Exp);
249 -- The type of the expression (not necessarily the same as R_Type)
252 -- Check the result expression of a scalar function against the subtype
253 -- of the function by inserting a conversion. This conversion must
254 -- eventually be performed for other classes of types, but for now it's
255 -- only done for scalars.
258 if Is_Scalar_Type (Exptyp) then
259 Rewrite (Exp, Convert_To (R_Type, Exp));
261 -- The expression is resolved to ensure that the conversion gets
262 -- expanded to generate a possible constraint check.
264 Analyze_And_Resolve (Exp, R_Type);
266 end Expand_Alfa_Simple_Function_Return;