1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- E X P _ S P A R K --
9 -- Copyright (C) 1992-2013, 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_SPARK is
45 -----------------------
46 -- Local Subprograms --
47 -----------------------
49 procedure Expand_SPARK_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_SPARK_N_Attribute_Reference (N : Node_Id);
56 -- Expand attributes 'Old and 'Result only
58 procedure Expand_SPARK_N_In (N : Node_Id);
59 -- Expand set membership into individual ones
61 procedure Expand_SPARK_N_Object_Renaming_Declaration (N : Node_Id);
62 -- Perform name evaluation for a renamed object
64 procedure Expand_SPARK_N_Simple_Return_Statement (N : Node_Id);
65 -- Insert conversion on function return if necessary
67 procedure Expand_SPARK_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_SPARK (N : Node_Id) is
81 when N_Attribute_Reference =>
82 Expand_SPARK_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 =>
99 Expand_SPARK_Call (N);
101 when N_Expanded_Name |
103 Expand_Potential_Renaming (N);
106 Expand_SPARK_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_SPARK_N_Object_Renaming_Declaration (N);
117 when N_Simple_Return_Statement =>
118 Expand_SPARK_N_Simple_Return_Statement (N);
120 -- In SPARK mode, no other constructs require expansion
127 -----------------------
128 -- Expand_SPARK_Call --
129 -----------------------
131 procedure Expand_SPARK_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_SPARK_Call;
189 ----------------------------------------
190 -- Expand_SPARK_N_Attribute_Reference --
191 ----------------------------------------
193 procedure Expand_SPARK_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_SPARK_N_Attribute_Reference;
207 -----------------------
208 -- Expand_SPARK_N_In --
209 -----------------------
211 procedure Expand_SPARK_N_In (N : Node_Id) is
213 if Present (Alternatives (N)) then
214 Expand_Set_Membership (N);
216 end Expand_SPARK_N_In;
218 ------------------------------------------------
219 -- Expand_SPARK_N_Object_Renaming_Declaration --
220 ------------------------------------------------
222 procedure Expand_SPARK_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_SPARK_N_Object_Renaming_Declaration;
229 --------------------------------------------
230 -- Expand_SPARK_N_Simple_Return_Statement --
231 --------------------------------------------
233 procedure Expand_SPARK_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_SPARK_Simple_Function_Return (N);
253 E_Generic_Procedure |
256 E_Return_Statement =>
264 when RE_Not_Available =>
266 end Expand_SPARK_N_Simple_Return_Statement;
268 -----------------------------------------
269 -- Expand_SPARK_Simple_Function_Return --
270 -----------------------------------------
272 procedure Expand_SPARK_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_SPARK_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;