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_Ch4; use Exp_Ch4;
29 with Exp_Ch6; use Exp_Ch6;
30 with Exp_Dbug; use Exp_Dbug;
31 with Exp_Util; use Exp_Util;
32 with Sem_Aux; use Sem_Aux;
33 with Sem_Res; use Sem_Res;
34 with Sem_Util; use Sem_Util;
35 with Sinfo; use Sinfo;
36 with Stand; use Stand;
38 package body Exp_SPARK is
40 -----------------------
41 -- Local Subprograms --
42 -----------------------
44 procedure Expand_SPARK_Call (N : Node_Id);
45 -- This procedure contains common processing for function and procedure
47 -- * expansion of actuals to introduce necessary temporaries
48 -- * replacement of renaming by subprogram renamed
50 procedure Expand_SPARK_N_Object_Renaming_Declaration (N : Node_Id);
51 -- Perform name evaluation for a renamed object
53 procedure Expand_Potential_Renaming (N : Node_Id);
54 -- N denotes a N_Identifier or N_Expanded_Name. If N references a renaming,
55 -- replace N with the renamed object.
61 procedure Expand_SPARK (N : Node_Id) is
65 -- Qualification of entity names in formal verification mode
66 -- is limited to the addition of a suffix for homonyms (see
67 -- Exp_Dbug.Qualify_Entity_Name). We used to qualify entity names
68 -- as full expansion does, but this was removed as this prevents the
69 -- verification back-end from using a short name for debugging and
70 -- user interaction. The verification back-end already takes care
71 -- of qualifying names when needed.
73 when N_Block_Statement |
75 N_Package_Declaration |
77 Qualify_Entity_Names (N);
79 when N_Subprogram_Call =>
80 Expand_SPARK_Call (N);
82 when N_Expanded_Name |
84 Expand_Potential_Renaming (N);
86 -- A NOT IN B gets transformed to NOT (A IN B). This is the same
87 -- expansion used in the normal case, so shared the code.
92 when N_Object_Renaming_Declaration =>
93 Expand_SPARK_N_Object_Renaming_Declaration (N);
95 -- In SPARK mode, no other constructs require expansion
102 -----------------------
103 -- Expand_SPARK_Call --
104 -----------------------
106 procedure Expand_SPARK_Call (N : Node_Id) is
107 Call_Node : constant Node_Id := N;
108 Parent_Subp : Entity_Id;
112 -- Ignore if previous error
114 if Nkind (Call_Node) in N_Has_Etype
115 and then Etype (Call_Node) = Any_Type
120 -- Call using access to subprogram with explicit dereference
122 if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
123 Subp := Etype (Name (Call_Node));
124 Parent_Subp := Empty;
126 -- Case of call to simple entry, where the Name is a selected component
127 -- whose prefix is the task, and whose selector name is the entry name
129 elsif Nkind (Name (Call_Node)) = N_Selected_Component then
130 Subp := Entity (Selector_Name (Name (Call_Node)));
131 Parent_Subp := Empty;
133 -- Case of call to member of entry family, where Name is an indexed
134 -- component, with the prefix being a selected component giving the
135 -- task and entry family name, and the index being the entry index.
137 elsif Nkind (Name (Call_Node)) = N_Indexed_Component then
138 Subp := Entity (Selector_Name (Prefix (Name (Call_Node))));
139 Parent_Subp := Empty;
144 Subp := Entity (Name (Call_Node));
145 Parent_Subp := Alias (Subp);
148 -- Various expansion activities for actuals are carried out
150 Expand_Actuals (N, Subp);
152 -- If the subprogram is a renaming, replace it in the call with the name
153 -- of the actual subprogram being called.
155 if Present (Parent_Subp) then
156 Parent_Subp := Ultimate_Alias (Parent_Subp);
158 -- The below setting of Entity is suspect, see F109-018 discussion???
160 Set_Entity (Name (Call_Node), Parent_Subp);
162 end Expand_SPARK_Call;
164 ------------------------------------------------
165 -- Expand_SPARK_N_Object_Renaming_Declaration --
166 ------------------------------------------------
168 procedure Expand_SPARK_N_Object_Renaming_Declaration (N : Node_Id) is
170 -- Unconditionally remove all side effects from the name
172 Evaluate_Name (Name (N));
173 end Expand_SPARK_N_Object_Renaming_Declaration;
175 -------------------------------
176 -- Expand_Potential_Renaming --
177 -------------------------------
179 procedure Expand_Potential_Renaming (N : Node_Id) is
180 E : constant Entity_Id := Entity (N);
181 T : constant Entity_Id := Etype (N);
184 -- Replace a reference to a renaming with the actual renamed object
186 if Ekind (E) in Object_Kind and then Present (Renamed_Object (E)) then
187 Rewrite (N, New_Copy_Tree (Renamed_Object (E)));
188 Reset_Analyzed_Flags (N);
189 Analyze_And_Resolve (N, T);
191 end Expand_Potential_Renaming;