1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2012, 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 -- Qualification of entity names in formal verification mode
85 -- is limited to the addition of a suffix for homonyms (see
86 -- Exp_Dbug.Qualify_Entity_Name). We used to qualify entity names
87 -- as full expansion does, but this was removed as this prevents the
88 -- verification back-end from using a short name for debugging and
89 -- user interaction. The verification back-end already takes care
90 -- of qualifying names when needed.
92 when N_Block_Statement |
94 N_Package_Declaration |
96 Qualify_Entity_Names
(N
);
98 when N_Subprogram_Call
=>
101 when N_Expanded_Name |
103 Expand_Potential_Renaming
(N
);
106 Expand_Alfa_N_In
(N
);
108 -- A NOT IN B gets transformed to NOT (A IN B). This is the same
109 -- expansion used in the normal case, so shared the code.
114 when N_Object_Renaming_Declaration
=>
115 Expand_Alfa_N_Object_Renaming_Declaration
(N
);
117 when N_Simple_Return_Statement
=>
118 Expand_Alfa_N_Simple_Return_Statement
(N
);
120 -- In Alfa mode, no other constructs require expansion
127 ----------------------
128 -- Expand_Alfa_Call --
129 ----------------------
131 procedure Expand_Alfa_Call
(N
: Node_Id
) is
132 Call_Node
: constant Node_Id
:= N
;
133 Parent_Subp
: Entity_Id
;
137 -- Ignore if previous error
139 if Nkind
(Call_Node
) in N_Has_Etype
140 and then Etype
(Call_Node
) = Any_Type
145 -- Call using access to subprogram with explicit dereference
147 if Nkind
(Name
(Call_Node
)) = N_Explicit_Dereference
then
148 Subp
:= Etype
(Name
(Call_Node
));
149 Parent_Subp
:= Empty
;
151 -- Case of call to simple entry, where the Name is a selected component
152 -- whose prefix is the task, and whose selector name is the entry name
154 elsif Nkind
(Name
(Call_Node
)) = N_Selected_Component
then
155 Subp
:= Entity
(Selector_Name
(Name
(Call_Node
)));
156 Parent_Subp
:= Empty
;
158 -- Case of call to member of entry family, where Name is an indexed
159 -- component, with the prefix being a selected component giving the
160 -- task and entry family name, and the index being the entry index.
162 elsif Nkind
(Name
(Call_Node
)) = N_Indexed_Component
then
163 Subp
:= Entity
(Selector_Name
(Prefix
(Name
(Call_Node
))));
164 Parent_Subp
:= Empty
;
169 Subp
:= Entity
(Name
(Call_Node
));
170 Parent_Subp
:= Alias
(Subp
);
173 -- Various expansion activities for actuals are carried out
175 Expand_Actuals
(N
, Subp
);
177 -- If the subprogram is a renaming, replace it in the call with the name
178 -- of the actual subprogram being called.
180 if Present
(Parent_Subp
) then
181 Parent_Subp
:= Ultimate_Alias
(Parent_Subp
);
183 -- The below setting of Entity is suspect, see F109-018 discussion???
185 Set_Entity
(Name
(Call_Node
), Parent_Subp
);
187 end Expand_Alfa_Call
;
189 ---------------------------------------
190 -- Expand_Alfa_N_Attribute_Reference --
191 ---------------------------------------
193 procedure Expand_Alfa_N_Attribute_Reference
(N
: Node_Id
) is
194 Id
: constant Attribute_Id
:= Get_Attribute_Id
(Attribute_Name
(N
));
200 Expand_N_Attribute_Reference
(N
);
205 end Expand_Alfa_N_Attribute_Reference
;
207 ----------------------
208 -- Expand_Alfa_N_In --
209 ----------------------
211 procedure Expand_Alfa_N_In
(N
: Node_Id
) is
213 if Present
(Alternatives
(N
)) then
214 Expand_Set_Membership
(N
);
216 end Expand_Alfa_N_In
;
218 -----------------------------------------------
219 -- Expand_Alfa_N_Object_Renaming_Declaration --
220 -----------------------------------------------
222 procedure Expand_Alfa_N_Object_Renaming_Declaration
(N
: Node_Id
) is
224 -- Unconditionally remove all side effects from the name
226 Evaluate_Name
(Name
(N
));
227 end Expand_Alfa_N_Object_Renaming_Declaration
;
229 -------------------------------------------
230 -- Expand_Alfa_N_Simple_Return_Statement --
231 -------------------------------------------
233 procedure Expand_Alfa_N_Simple_Return_Statement
(N
: Node_Id
) is
235 -- Defend against previous errors (i.e. the return statement calls a
236 -- function that is not available in configurable runtime).
238 if Present
(Expression
(N
))
239 and then Nkind
(Expression
(N
)) = N_Empty
244 -- Distinguish the function and non-function cases:
246 case Ekind
(Return_Applies_To
(Return_Statement_Entity
(N
))) is
249 E_Generic_Function
=>
250 Expand_Alfa_Simple_Function_Return
(N
);
253 E_Generic_Procedure |
256 E_Return_Statement
=>
264 when RE_Not_Available
=>
266 end Expand_Alfa_N_Simple_Return_Statement
;
268 ----------------------------------------
269 -- Expand_Alfa_Simple_Function_Return --
270 ----------------------------------------
272 procedure Expand_Alfa_Simple_Function_Return
(N
: Node_Id
) is
273 Scope_Id
: constant Entity_Id
:=
274 Return_Applies_To
(Return_Statement_Entity
(N
));
275 -- The function we are returning from
277 R_Type
: constant Entity_Id
:= Etype
(Scope_Id
);
278 -- The result type of the function
280 Exp
: constant Node_Id
:= Expression
(N
);
281 pragma Assert
(Present
(Exp
));
283 Exptyp
: constant Entity_Id
:= Etype
(Exp
);
284 -- The type of the expression (not necessarily the same as R_Type)
287 -- Check the result expression of a scalar function against the subtype
288 -- of the function by inserting a conversion. This conversion must
289 -- eventually be performed for other classes of types, but for now it's
290 -- only done for scalars.
293 if Is_Scalar_Type
(Exptyp
) then
294 Rewrite
(Exp
, Convert_To
(R_Type
, Exp
));
296 -- The expression is resolved to ensure that the conversion gets
297 -- expanded to generate a possible constraint check.
299 Analyze_And_Resolve
(Exp
, R_Type
);
301 end Expand_Alfa_Simple_Function_Return
;
303 -------------------------------
304 -- Expand_Potential_Renaming --
305 -------------------------------
307 procedure Expand_Potential_Renaming
(N
: Node_Id
) is
308 E
: constant Entity_Id
:= Entity
(N
);
309 T
: constant Entity_Id
:= Etype
(N
);
312 -- Replace a reference to a renaming with the actual renamed object
314 if Ekind
(E
) in Object_Kind
and then Present
(Renamed_Object
(E
)) then
315 Rewrite
(N
, New_Copy_Tree
(Renamed_Object
(E
)));
316 Reset_Analyzed_Flags
(N
);
317 Analyze_And_Resolve
(N
, T
);
319 end Expand_Potential_Renaming
;