1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                             E X P _ A L F A                              --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1992-2012, Free Software Foundation, Inc.         --
10--                                                                          --
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.          --
20--                                                                          --
21-- GNAT was originally developed  by the GNAT team at  New York University. --
22-- Extensive contributions were provided by Ada Core Technologies Inc.      --
23--                                                                          --
24------------------------------------------------------------------------------
25
26with Atree;    use Atree;
27with Einfo;    use Einfo;
28with Exp_Attr; use Exp_Attr;
29with Exp_Ch4;  use Exp_Ch4;
30with Exp_Ch6;  use Exp_Ch6;
31with Exp_Dbug; use Exp_Dbug;
32with Exp_Util; use Exp_Util;
33with Nlists;   use Nlists;
34with Rtsfind;  use Rtsfind;
35with Sem_Aux;  use Sem_Aux;
36with Sem_Res;  use Sem_Res;
37with Sem_Util; use Sem_Util;
38with Sinfo;    use Sinfo;
39with Snames;   use Snames;
40with Stand;    use Stand;
41with Tbuild;   use Tbuild;
42
43package body Exp_Alfa is
44
45   -----------------------
46   -- Local Subprograms --
47   -----------------------
48
49   procedure Expand_Alfa_Call (N : Node_Id);
50   --  This procedure contains common processing for function and procedure
51   --  calls:
52   --    * expansion of actuals to introduce necessary temporaries
53   --    * replacement of renaming by subprogram renamed
54
55   procedure Expand_Alfa_N_Attribute_Reference (N : Node_Id);
56   --  Expand attributes 'Old and 'Result only
57
58   procedure Expand_Alfa_N_In (N : Node_Id);
59   --  Expand set membership into individual ones
60
61   procedure Expand_Alfa_N_Object_Renaming_Declaration (N : Node_Id);
62   --  Perform name evaluation for a renamed object
63
64   procedure Expand_Alfa_N_Simple_Return_Statement (N : Node_Id);
65   --  Insert conversion on function return if necessary
66
67   procedure Expand_Alfa_Simple_Function_Return (N : Node_Id);
68   --  Expand simple return from function
69
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.
73
74   -----------------
75   -- Expand_Alfa --
76   -----------------
77
78   procedure Expand_Alfa (N : Node_Id) is
79   begin
80      case Nkind (N) is
81         when N_Attribute_Reference =>
82            Expand_Alfa_N_Attribute_Reference (N);
83
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.
91
92         when N_Block_Statement     |
93              N_Package_Body        |
94              N_Package_Declaration |
95              N_Subprogram_Body     =>
96            Qualify_Entity_Names (N);
97
98         when N_Subprogram_Call     =>
99            Expand_Alfa_Call (N);
100
101         when N_Expanded_Name |
102              N_Identifier    =>
103            Expand_Potential_Renaming (N);
104
105         when N_In =>
106            Expand_Alfa_N_In (N);
107
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.
110
111         when N_Not_In =>
112            Expand_N_Not_In (N);
113
114         when N_Object_Renaming_Declaration =>
115            Expand_Alfa_N_Object_Renaming_Declaration (N);
116
117         when N_Simple_Return_Statement =>
118            Expand_Alfa_N_Simple_Return_Statement (N);
119
120         --  In Alfa mode, no other constructs require expansion
121
122         when others =>
123            null;
124      end case;
125   end Expand_Alfa;
126
127   ----------------------
128   -- Expand_Alfa_Call --
129   ----------------------
130
131   procedure Expand_Alfa_Call (N : Node_Id) is
132      Call_Node   : constant Node_Id := N;
133      Parent_Subp : Entity_Id;
134      Subp        : Entity_Id;
135
136   begin
137      --  Ignore if previous error
138
139      if Nkind (Call_Node) in N_Has_Etype
140        and then Etype (Call_Node) = Any_Type
141      then
142         return;
143      end if;
144
145      --  Call using access to subprogram with explicit dereference
146
147      if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
148         Subp        := Etype (Name (Call_Node));
149         Parent_Subp := Empty;
150
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
153
154      elsif Nkind (Name (Call_Node)) = N_Selected_Component then
155         Subp        := Entity (Selector_Name (Name (Call_Node)));
156         Parent_Subp := Empty;
157
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.
161
162      elsif Nkind (Name (Call_Node)) = N_Indexed_Component then
163         Subp        := Entity (Selector_Name (Prefix (Name (Call_Node))));
164         Parent_Subp := Empty;
165
166      --  Normal case
167
168      else
169         Subp        := Entity (Name (Call_Node));
170         Parent_Subp := Alias (Subp);
171      end if;
172
173      --  Various expansion activities for actuals are carried out
174
175      Expand_Actuals (N, Subp);
176
177      --  If the subprogram is a renaming, replace it in the call with the name
178      --  of the actual subprogram being called.
179
180      if Present (Parent_Subp) then
181         Parent_Subp := Ultimate_Alias (Parent_Subp);
182
183         --  The below setting of Entity is suspect, see F109-018 discussion???
184
185         Set_Entity (Name (Call_Node), Parent_Subp);
186      end if;
187   end Expand_Alfa_Call;
188
189   ---------------------------------------
190   -- Expand_Alfa_N_Attribute_Reference --
191   ---------------------------------------
192
193   procedure Expand_Alfa_N_Attribute_Reference (N : Node_Id) is
194      Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
195
196   begin
197      case Id is
198         when Attribute_Old    |
199              Attribute_Result =>
200            Expand_N_Attribute_Reference (N);
201
202         when others =>
203            null;
204      end case;
205   end Expand_Alfa_N_Attribute_Reference;
206
207   ----------------------
208   -- Expand_Alfa_N_In --
209   ----------------------
210
211   procedure Expand_Alfa_N_In (N : Node_Id) is
212   begin
213      if Present (Alternatives (N)) then
214         Expand_Set_Membership (N);
215      end if;
216   end Expand_Alfa_N_In;
217
218   -----------------------------------------------
219   -- Expand_Alfa_N_Object_Renaming_Declaration --
220   -----------------------------------------------
221
222   procedure Expand_Alfa_N_Object_Renaming_Declaration (N : Node_Id) is
223   begin
224      --  Unconditionally remove all side effects from the name
225
226      Evaluate_Name (Name (N));
227   end Expand_Alfa_N_Object_Renaming_Declaration;
228
229   -------------------------------------------
230   -- Expand_Alfa_N_Simple_Return_Statement --
231   -------------------------------------------
232
233   procedure Expand_Alfa_N_Simple_Return_Statement (N : Node_Id) is
234   begin
235      --  Defend against previous errors (i.e. the return statement calls a
236      --  function that is not available in configurable runtime).
237
238      if Present (Expression (N))
239        and then Nkind (Expression (N)) = N_Empty
240      then
241         return;
242      end if;
243
244      --  Distinguish the function and non-function cases:
245
246      case Ekind (Return_Applies_To (Return_Statement_Entity (N))) is
247
248         when E_Function          |
249              E_Generic_Function  =>
250            Expand_Alfa_Simple_Function_Return (N);
251
252         when E_Procedure         |
253              E_Generic_Procedure |
254              E_Entry             |
255              E_Entry_Family      |
256              E_Return_Statement =>
257            null;
258
259         when others =>
260            raise Program_Error;
261      end case;
262
263   exception
264      when RE_Not_Available =>
265         return;
266   end Expand_Alfa_N_Simple_Return_Statement;
267
268   ----------------------------------------
269   -- Expand_Alfa_Simple_Function_Return --
270   ----------------------------------------
271
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
276
277      R_Type : constant Entity_Id := Etype (Scope_Id);
278      --  The result type of the function
279
280      Exp : constant Node_Id := Expression (N);
281      pragma Assert (Present (Exp));
282
283      Exptyp : constant Entity_Id := Etype (Exp);
284      --  The type of the expression (not necessarily the same as R_Type)
285
286   begin
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.
291      --  ???
292
293      if Is_Scalar_Type (Exptyp) then
294         Rewrite (Exp, Convert_To (R_Type, Exp));
295
296         --  The expression is resolved to ensure that the conversion gets
297         --  expanded to generate a possible constraint check.
298
299         Analyze_And_Resolve (Exp, R_Type);
300      end if;
301   end Expand_Alfa_Simple_Function_Return;
302
303   -------------------------------
304   -- Expand_Potential_Renaming --
305   -------------------------------
306
307   procedure Expand_Potential_Renaming (N : Node_Id) is
308      E : constant Entity_Id := Entity (N);
309      T : constant Entity_Id := Etype (N);
310
311   begin
312      --  Replace a reference to a renaming with the actual renamed object
313
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);
318      end if;
319   end Expand_Potential_Renaming;
320
321end Exp_Alfa;
322