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_Ch6; use Exp_Ch6;
30 with Exp_Dbug; use Exp_Dbug;
31 with Rtsfind; use Rtsfind;
32 with Sem_Aux; use Sem_Aux;
33 with Sem_Res; use Sem_Res;
34 with Sinfo; use Sinfo;
35 with Snames; use Snames;
36 with Stand; use Stand;
37 with Tbuild; use Tbuild;
39 package body Exp_Alfa is
41 -----------------------
42 -- Local Subprograms --
43 -----------------------
45 procedure Expand_Alfa_Call (N : Node_Id);
46 -- This procedure contains common processing for function and procedure
48 -- * expansion of actuals to introduce necessary temporaries
49 -- * replacement of renaming by subprogram renamed
51 procedure Expand_Alfa_N_Attribute_Reference (N : Node_Id);
52 -- Expand attributes 'Old and 'Result only
54 procedure Expand_Alfa_N_Simple_Return_Statement (N : Node_Id);
55 -- Insert conversion on function return if necessary
57 procedure Expand_Alfa_Simple_Function_Return (N : Node_Id);
58 -- Expand simple return from function
64 procedure Expand_Alfa (N : Node_Id) is
69 N_Package_Declaration |
72 Qualify_Entity_Names (N);
74 when N_Simple_Return_Statement =>
75 Expand_Alfa_N_Simple_Return_Statement (N);
77 when N_Function_Call |
78 N_Procedure_Call_Statement =>
81 when N_Attribute_Reference =>
82 Expand_Alfa_N_Attribute_Reference (N);
89 ----------------------
90 -- Expand_Alfa_Call --
91 ----------------------
93 procedure Expand_Alfa_Call (N : Node_Id) is
94 Call_Node : constant Node_Id := N;
95 Parent_Subp : Entity_Id;
99 -- Ignore if previous error
101 if Nkind (Call_Node) in N_Has_Etype
102 and then Etype (Call_Node) = Any_Type
107 -- Call using access to subprogram with explicit dereference
109 if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
110 Subp := Etype (Name (Call_Node));
111 Parent_Subp := Empty;
113 -- Case of call to simple entry, where the Name is a selected component
114 -- whose prefix is the task, and whose selector name is the entry name
116 elsif Nkind (Name (Call_Node)) = N_Selected_Component then
117 Subp := Entity (Selector_Name (Name (Call_Node)));
118 Parent_Subp := Empty;
120 -- Case of call to member of entry family, where Name is an indexed
121 -- component, with the prefix being a selected component giving the
122 -- task and entry family name, and the index being the entry index.
124 elsif Nkind (Name (Call_Node)) = N_Indexed_Component then
125 Subp := Entity (Selector_Name (Prefix (Name (Call_Node))));
126 Parent_Subp := Empty;
131 Subp := Entity (Name (Call_Node));
132 Parent_Subp := Alias (Subp);
135 -- Various expansion activities for actuals are carried out
137 Expand_Actuals (N, Subp);
139 -- If the subprogram is a renaming, replace it in the call with the name
140 -- of the actual subprogram being called.
142 if Present (Parent_Subp) then
143 Parent_Subp := Ultimate_Alias (Parent_Subp);
145 -- The below setting of Entity is suspect, see F109-018 discussion???
147 Set_Entity (Name (Call_Node), Parent_Subp);
150 end Expand_Alfa_Call;
152 ---------------------------------------
153 -- Expand_Alfa_N_Attribute_Reference --
154 ---------------------------------------
156 procedure Expand_Alfa_N_Attribute_Reference (N : Node_Id) is
157 Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
163 Expand_N_Attribute_Reference (N);
168 end Expand_Alfa_N_Attribute_Reference;
170 -------------------------------------------
171 -- Expand_Alfa_N_Simple_Return_Statement --
172 -------------------------------------------
174 procedure Expand_Alfa_N_Simple_Return_Statement (N : Node_Id) is
176 -- Defend against previous errors (i.e. the return statement calls a
177 -- function that is not available in configurable runtime).
179 if Present (Expression (N))
180 and then Nkind (Expression (N)) = N_Empty
185 -- Distinguish the function and non-function cases:
187 case Ekind (Return_Applies_To (Return_Statement_Entity (N))) is
190 E_Generic_Function =>
191 Expand_Alfa_Simple_Function_Return (N);
194 E_Generic_Procedure |
197 E_Return_Statement =>
198 -- Expand_Non_Function_Return (N);
206 when RE_Not_Available =>
208 end Expand_Alfa_N_Simple_Return_Statement;
210 ----------------------------------------
211 -- Expand_Alfa_Simple_Function_Return --
212 ----------------------------------------
214 procedure Expand_Alfa_Simple_Function_Return (N : Node_Id) is
215 Scope_Id : constant Entity_Id :=
216 Return_Applies_To (Return_Statement_Entity (N));
217 -- The function we are returning from
219 R_Type : constant Entity_Id := Etype (Scope_Id);
220 -- The result type of the function
222 Exp : constant Node_Id := Expression (N);
223 pragma Assert (Present (Exp));
225 Exptyp : constant Entity_Id := Etype (Exp);
226 -- The type of the expression (not necessarily the same as R_Type)
229 -- Check the result expression of a scalar function against the subtype
230 -- of the function by inserting a conversion. This conversion must
231 -- eventually be performed for other classes of types, but for now it's
232 -- only done for scalars.
235 if Is_Scalar_Type (Exptyp) then
236 Rewrite (Exp, Convert_To (R_Type, Exp));
238 -- The expression is resolved to ensure that the conversion gets
239 -- expanded to generate a possible constraint check.
241 Analyze_And_Resolve (Exp, R_Type);
243 end Expand_Alfa_Simple_Function_Return;